          let pat =
 Index: typing/ctype.ml
 ===================================================================
---- typing/ctype.ml	(revision 13146)
+--- typing/ctype.ml	(revision 13157)
 +++ typing/ctype.ml	(working copy)
 @@ -981,6 +981,25 @@
                      if keep then more else newty more.desc

Index: Changes
===================================================================
--- Changes	(revision 13146)
+++ Changes	(working copy)
@@ -1,6 +1,11 @@
 Next version

 let iter_ppat f p =
   match p.ppat_desc with
   | Ppat_any | Ppat_var _ | Ppat_constant _
@@ -3037,16 +3059,20 @@
 
 and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
   (* ty_arg is _fully_ generalized *)
-  let dont_propagate, has_gadts =
-    let patterns = List.map fst caselist in
-    List.exists contains_polymorphic_variant patterns,
-    List.exists (contains_gadt env) patterns in
+  let patterns = List.map fst caselist in
+  let erase_either =
+    List.exists contains_polymorphic_variant patterns
+    && contains_variant_either ty_arg
+  and has_gadts = List.exists (contains_gadt env) patterns in
 (*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
-  let ty_arg, ty_res, env =
+  let ty_arg =
+    if (has_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  and ty_res, env =
     if has_gadts && not !Clflags.principal then
