diff --git a/typing/ctype.ml b/typing/ctype.ml
index d1ff9da..2125d00 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -2948,6 +2948,21 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
         link_type t1 t2
     | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
         ()
+    | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+         when Path.same p1 p2 ->
+       begin try
+           moregen_list inst_nongen type_pairs env tl1 tl2 ;
+           (* expand afterwards, this seems to be an expected side-effect *)
+           ignore (expand_head env t1 ) ;
+           ignore (expand_head env t2 ) ;
+         with e ->
+           let t1' = expand_head env t1 in
+           let t2' = expand_head env t2 in
+           let t1' = repr t1' and t2' = repr t2' in
+           (* prevent non-termination (is this really necessary?) *)
+           if t1' == t1 && t2' == t2 then raise e else
+             moregen inst_nongen type_pairs env t1 t2
+       end
     | _ ->
         let t1' = expand_head env t1 in
         let t2' = expand_head env t2 in
@@ -3213,6 +3228,23 @@ let rec eqtype rename type_pairs subst env t1 t2 =
         end
     | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
         ()
+
+    | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
+         when Path.same p1 p2 ->
+       (* Optimize equality of large type-constructors.
+          Equality of all arguments implies equality of the result, expand 
+          only in case of non-equality (since equivalence does not hold) *)          
+       begin try
+         eqtype_list rename type_pairs subst env tl1 tl2
+       with e -> 
+           let t1' = expand_head_rigid env t1 in
+           let t2' = expand_head_rigid env t2 in
+           let t1' = repr t1' and t2' = repr t2' in
+           (* prevent non-termination (is this really necessary?) *)
+           if t1' == t1 && t2' == t2 then raise e else
+             eqtype rename type_pairs subst env t1' t2'
+       end
+
     | _ ->
         let t1' = expand_head_rigid env t1 in
         let t2' = expand_head_rigid env t2 in