diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index b3fc1f33aaeaa145a79dc8fe460b8d79929d4ab3..af973f1830d8ad9611d9d5fdcca7021f1d40367e 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -62,12 +62,7 @@ data OpCode = OpTestDelay Double Bool [String]
             deriving (Show, Read, Eq)
 
 
--- | Computes the OP_ID for an OpCode.
-opID :: OpCode -> String
-opID (OpTestDelay _ _ _) = "OP_TEST_DELAY"
-opID (OpInstanceReplaceDisks _ _ _ _ _) = "OP_INSTANCE_REPLACE_DISKS"
-opID (OpInstanceFailover {}) = "OP_INSTANCE_FAILOVER"
-opID (OpInstanceMigrate  {}) = "OP_INSTANCE_MIGRATE"
+$(THH.genOpID ''OpCode "opID")
 
 -- | Loads an OpCode from the JSON serialised form.
 loadOpCode :: JSValue -> J.Result OpCode
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 6e539a43d4d023d1bb388213aca3279d47faa8a6..808836f20d1700ec46958ebd8de93bfb808d8777 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -31,9 +31,12 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 
 module Ganeti.THH ( declareSADT
                   , makeJSONInstance
+                  , genOpID
                   ) where
 
+import Control.Monad (liftM)
 import Data.Char
+import Data.List
 import Language.Haskell.TH
 
 import qualified Text.JSON as JSON
@@ -54,6 +57,12 @@ toStrName = mkName . (++ "ToString") . ensureLower
 fromStrName :: String -> Name
 fromStrName = mkName . (++ "FromString") . ensureLower
 
+-- | Converts a name to it's varE/litE representations.
+--
+reprE :: Either String Name -> Q Exp
+reprE (Left name) = litE (StringL name)
+reprE (Right name) = varE name
+
 -- | Generates a data type declaration.
 --
 -- The type will have a fixed list of instances.
@@ -72,13 +81,13 @@ strADTDecl name constructors =
 -- nameToString Cons1 = var1
 -- nameToString Cons2 = \"value2\"
 -- @
-genToString :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genToString :: Name -> Name -> [(String, Either String Name)] -> Q [Dec]
 genToString fname tname constructors = do
   sigt <- [t| $(conT tname) -> String |]
   -- the body clauses, matching on the constructor and returning the
   -- string value
   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
-                             (normalB (varE  v)) []) constructors
+                             (normalB (reprE v)) []) constructors
   return [SigD fname sigt, FunD fname clauses]
 
 -- | Generates a fromString function.
@@ -135,7 +144,9 @@ declareSADT :: String -> [(String, Name)] -> Q [Dec]
 declareSADT sname cons = do
   let name = mkName sname
       ddecl = strADTDecl name (map fst cons)
-  tostr <- genToString (toStrName sname) name cons
+      -- process cons in the format expected by genToString
+      cons' = map (\(a, b) -> (a, Right b)) cons
+  tostr <- genToString (toStrName sname) name cons'
   fromstr <- genFromString (fromStrName sname) name cons
   return $ ddecl:tostr ++ fromstr
 
@@ -184,3 +195,32 @@ makeJSONInstance name = do
   showJ <- genShowJSON base
   readJ <- genReadJSON base
   return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
+
+-- | Transforms a CamelCase string into an_underscore_based_one.
+deCamelCase :: String -> String
+deCamelCase =
+    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
+
+-- | Computes the name of a given constructor
+constructorName :: Con -> Q Name
+constructorName (NormalC name _) = return name
+constructorName (RecC name _)    = return name
+constructorName x                = fail $ "Unhandled constructor " ++ show x
+
+-- | Builds the constructor-to-string function.
+--
+-- This generates a simple function of the following form:
+--
+-- @
+-- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE"
+-- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO"
+-- @
+--
+-- This builds a custom list of name/string pairs and then uses
+-- 'genToString' to actually generate the function
+genOpID :: Name -> String -> Q [Dec]
+genOpID name fname = do
+  TyConI (DataD _ _ _ cons _) <- reify name
+  cnames <- mapM (liftM nameBase . constructorName) cons
+  let svalues = map (Left . deCamelCase) cnames
+  genToString (mkName fname) name $ zip cnames svalues