diff --git a/typed-racket-lib/typed-racket/base-env/base-env-indexing-abs.rkt b/typed-racket-lib/typed-racket/base-env/base-env-indexing-abs.rkt
index 6e01316e..5db300e1 100644
--- a/typed-racket-lib/typed-racket/base-env/base-env-indexing-abs.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-env-indexing-abs.rkt
@@ -4,7 +4,7 @@
  "../utils/utils.rkt"
  (for-template racket/base racket/list racket/unsafe/ops racket/flonum racket/extflonum racket/fixnum)
  (utils tc-utils) 
- (rename-in (types union abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym]))
+ (rename-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym]))
 
 (provide indexing)
 
diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt
index 4fff1698..fc8a5b26 100644
--- a/typed-racket-lib/typed-racket/base-env/base-env.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-env.rkt
@@ -23,22 +23,29 @@
  (only-in racket/private/pre-base new-apply-proc)
  (only-in (types abbrev) [-Boolean B] [-Symbol Sym] -Flat)
  (only-in (types numeric-tower) [-Number N])
- (only-in (rep type-rep values-rep)
-          make-ClassTop
-          make-UnitTop
-          make-Name
+ (only-in (rep type-rep values-rep object-rep)
+          -car
+          -cdr
+          -force
+          -field
+          -syntax-e
+          -ClassTop
+          -UnitTop
           make-ValuesDots
-          make-MPairTop
-          make-BoxTop make-ChannelTop make-VectorTop
-          make-ThreadCellTop
+          -MPairTop
+          -BoxTop
+          -ChannelTop
+          -VectorTop
+          -ThreadCellTop
           make-Ephemeron
           make-CustodianBox
           make-HeterogeneousVector
           make-Continuation-Mark-Keyof
-          make-Continuation-Mark-KeyTop
+          -Continuation-Mark-KeyTop
           make-Prompt-Tagof
-          make-Prompt-TagTop
-          make-StructType make-StructTypeTop
+          -Prompt-TagTop
+          make-StructType
+          -StructTypeTop
           make-ListDots))
 
 ;; Racket Reference
@@ -829,18 +836,18 @@
 [unsafe-set-mcdr! (-poly (a b)
                          (cl->* (-> (-mpair a b) b -Void)
                                 (-> (-mlst a) (-mlst a) -Void)))]
-[mpair? (make-pred-ty (make-MPairTop))]
+[mpair? (make-pred-ty -MPairTop)]
 [mlist (-poly (a) (->* (list) a (-mlst a)))]
 [mlength (-poly (a) (-> (-mlst a) -Index))]
 [mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))]
 [mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))]
 
 ;; Section 4.11 (Vectors)
-[vector? (make-pred-ty (make-VectorTop))]
+[vector? (make-pred-ty -VectorTop)]
 [vector->list (-poly (a) (cl->* (-> (-vec a) (-lst a))
-                                (-> (make-VectorTop) (-lst Univ))))]
+                                (-> -VectorTop (-lst Univ))))]
 [list->vector (-poly (a) (-> (-lst a) (-vec a)))]
-[vector-length ((make-VectorTop) . -> . -Index)]
+[vector-length (-VectorTop . -> . -Index)]
 [vector (-poly (a) (->* (list) a (-vec a)))]
 [vector-immutable (-poly (a) (->* (list) a (-vec a)))]
 [vector->immutable-vector (-poly (a) (-> (-vec a) (-vec a)))]
@@ -893,26 +900,26 @@
 [box-immutable (-poly (a) (a . -> . (-box a)))]
 [unbox (-poly (a) (cl->*
                    ((-box a) . -> . a)
-                   ((make-BoxTop) . -> . Univ)))]
+                   (-BoxTop . -> . Univ)))]
 [set-box! (-poly (a) ((-box a) a . -> . -Void))]
 [box-cas! (-poly (a) ((-box a) a a . -> . -Boolean))]
 [unsafe-unbox (-poly (a) (cl->*
                           ((-box a) . -> . a)
-                          ((make-BoxTop) . -> . Univ)))]
+                          (-BoxTop . -> . Univ)))]
 [unsafe-set-box! (-poly (a) ((-box a) a . -> . -Void))]
 [unsafe-unbox* (-poly (a) (cl->*
                            ((-box a) . -> . a)
-                           ((make-BoxTop) . -> . Univ)))]
+                           (-BoxTop . -> . Univ)))]
 [unsafe-set-box*! (-poly (a) ((-box a) a . -> . -Void))]
 [unsafe-box*-cas! (-poly (a) ((-box a) a a . -> . -Boolean))]
-[box? (make-pred-ty (make-BoxTop))]
+[box? (make-pred-ty -BoxTop)]
 
 ;; Section 4.13 (Hash Tables)
-[hash? (make-pred-ty -HashTop)]
-[hash-eq? (-> -HashTop B)]
-[hash-eqv? (-> -HashTop B)]
-[hash-equal? (-> -HashTop B)]
-[hash-weak? (-> -HashTop B)]
+[hash? (make-pred-ty -HashtableTop)]
+[hash-eq? (-> -HashtableTop B)]
+[hash-eqv? (-> -HashtableTop B)]
+[hash-equal? (-> -HashtableTop B)]
+[hash-weak? (-> -HashtableTop B)]
 [hash (-poly (a b) (cl->* (-> (-HT a b))
                           (a b . -> . (-HT a b))
                           (a b a b . -> . (-HT a b))
@@ -944,11 +951,11 @@
                  (cl-> [((-HT a b) a) b]
                        [((-HT a b) a (-val #f)) (-opt b)]
                        [((-HT a b) a (-> c)) (Un b c)]
-                       [(-HashTop a) Univ]
-                       [(-HashTop a (-val #f)) Univ]
-                       [(-HashTop a (-> c)) Univ]))]
+                       [(-HashtableTop a) Univ]
+                       [(-HashtableTop a (-val #f)) Univ]
+                       [(-HashtableTop a (-> c)) Univ]))]
 [hash-ref! (-poly (a b) (-> (-HT a b) a (-> b) b))]
-[hash-has-key? (-HashTop Univ . -> . B)]
+[hash-has-key? (-HashtableTop Univ . -> . B)]
 [hash-update! (-poly (a b)
                      (cl-> [((-HT a b) a (-> b b)) -Void]
                            [((-HT a b) a (-> b b) (-> b)) -Void]))]
@@ -956,21 +963,21 @@
                     (cl-> [((-HT a b) a (-> b b)) (-HT a b)]
                           [((-HT a b) a (-> b b) (-> b)) (-HT a b)]))]
 [hash-remove (-poly (a b) (cl-> [((-HT a b) Univ) (-HT a b)]
-                                [(-HashTop Univ) -HashTop]))]
+                                [(-HashtableTop Univ) -HashtableTop]))]
 [hash-remove! (-poly (a b) (cl-> [((-HT a b) a) -Void]
-                                 [(-HashTop a) -Void]))]
+                                 [(-HashtableTop a) -Void]))]
 [hash-map (-poly (a b c) (cl-> [((-HT a b) (a b . -> . c)) (-lst c)]
-                               [(-HashTop (Univ Univ . -> . c)) (-lst c)]))]
+                               [(-HashtableTop (Univ Univ . -> . c)) (-lst c)]))]
 [hash-for-each (-poly (a b c) (cl-> [((-HT a b) (-> a b c)) -Void]
-                                    [(-HashTop (-> Univ Univ c)) -Void]))]
-[hash-count (-> -HashTop -Index)]
-[hash-empty? (-> -HashTop -Boolean)]
+                                    [(-HashtableTop (-> Univ Univ c)) -Void]))]
+[hash-count (-> -HashtableTop -Index)]
+[hash-empty? (-> -HashtableTop -Boolean)]
 [hash-keys (-poly (a b) (cl-> [((-HT a b)) (-lst a)]
-                              [(-HashTop) (-lst Univ)]))]
+                              [(-HashtableTop) (-lst Univ)]))]
 [hash-values (-poly (a b) (cl-> [((-HT a b)) (-lst b)]
-                                [(-HashTop) (-lst Univ)]))]
+                                [(-HashtableTop) (-lst Univ)]))]
 [hash->list (-poly (a b) (cl-> [((-HT a b)) (-lst (-pair a b))]
-                               [(-HashTop) (-lst (-pair Univ Univ))]))]
+                               [(-HashtableTop) (-lst (-pair Univ Univ))]))]
 
 [hash-copy (-poly (a b) (-> (-HT a b) (-HT a b)))]
 [eq-hash-code (-> Univ -Fixnum)]
@@ -980,23 +987,23 @@
 [hash-iterate-first (-poly (a b)
                            (cl->*
                             ((-HT a b) . -> . (Un (-val #f) -Integer))
-                            (-> -HashTop (Un (-val #f) -Integer))))]
+                            (-> -HashtableTop (Un (-val #f) -Integer))))]
 [hash-iterate-next (-poly (a b)
                            (cl->*
                             ((-HT a b) -Integer . -> . (Un (-val #f) -Integer))
-                            (-> -HashTop -Integer (Un (-val #f) -Integer))))]
+                            (-> -HashtableTop -Integer (Un (-val #f) -Integer))))]
 [hash-iterate-key (-poly (a b)
                            (cl->* ((-HT a b) -Integer . -> . a)
-                                  (-> -HashTop -Integer Univ)))]
+                                  (-> -HashtableTop -Integer Univ)))]
 [hash-iterate-value (-poly (a b)
                            (cl->* ((-HT a b) -Integer . -> . b)
-                                  (-> -HashTop -Integer Univ)))]
+                                  (-> -HashtableTop -Integer Univ)))]
 [hash-iterate-pair (-poly (a b)
                            (cl->* ((-HT a b) -Integer . -> . (-pair a b))
-                                  (-> -HashTop -Integer Univ)))]
+                                  (-> -HashtableTop -Integer Univ)))]
 [hash-iterate-key+value (-poly (a b)
                            (cl->* ((-HT a b) -Integer . -> . (-values (list a b)))
-                                  (-> -HashTop -Integer (-values (list Univ Univ)))))]
+                                  (-> -HashtableTop -Integer (-values (list Univ Univ)))))]
 
 [make-custom-hash (->opt (-> Univ Univ Univ) (-> Univ -Nat) [(-> Univ -Nat)] Univ)]
 [make-immutable-custom-hash (->opt (-> Univ Univ Univ) (-> Univ -Nat) [(-> Univ -Nat)] Univ)]
@@ -1146,7 +1153,7 @@
 ;; Section 5.2 (Structure Types)
 [make-struct-type
  (->opt -Symbol
-        (-opt (make-StructTypeTop))
+        (-opt -StructTypeTop)
         -Nat -Nat
         [Univ
          (-lst (-pair -Struct-Type-Property Univ))
@@ -1155,7 +1162,7 @@
          (-lst -Nat)
          (-opt top-func)
          (-opt -Symbol)]
-        (-values (list (make-StructTypeTop) top-func top-func top-func top-func)))]
+        (-values (list -StructTypeTop top-func top-func top-func top-func)))]
 [make-struct-field-accessor (->opt top-func -Nat [(-opt -Symbol)] top-func)]
 [make-struct-field-mutator  (->opt top-func -Nat [(-opt -Symbol)] top-func)]
 
@@ -1173,33 +1180,33 @@
 ;; Section 5.6 (Structure Utilities)
 [struct->vector (Univ . -> . (-vec Univ))]
 [struct? (-> Univ -Boolean)]
-[struct-type? (make-pred-ty (make-StructTypeTop))]
+[struct-type? (make-pred-ty -StructTypeTop)]
 
 ;; Section 6.2 (Classes)
 [object% (-class)]
 
 ;; Section 6.11 (Object, Class, and Interface Utilities)
 [object? (make-pred-ty (-object))]
-[class? (make-pred-ty (make-ClassTop))]
+[class? (make-pred-ty -ClassTop)]
 ;; TODO: interface?
 ;;       generic?
 [object=? (-> (-object) (-object) -Boolean)]
 [object->vector (->opt (-object) [Univ] (-vec Univ))]
 ;; TODO: class->interface
 ;;       object-interface
-[is-a? (-> Univ (make-ClassTop) -Boolean)]
-[subclass? (-> Univ (make-ClassTop) -Boolean)]
+[is-a? (-> Univ -ClassTop -Boolean)]
+[subclass? (-> Univ -ClassTop -Boolean)]
 ;; TODO: implementation?
 ;;       interface-extension?
 ;;       method-in-interface?
 ;;       interface->method-names
 [object-method-arity-includes? (-> (-object) -Symbol -Nat -Boolean)]
 [field-names (-> (-object) (-lst -Symbol))]
-[object-info (-> (-object) (-values (list (Un (make-ClassTop) (-val #f)) -Boolean)))]
+[object-info (-> (-object) (-values (list (Un -ClassTop (-val #f)) -Boolean)))]
 ;; TODO: class-info (is this sound to allow?)
 
 ;; Section 7.8 (Unit Utilities)
-[unit? (make-pred-ty (make-UnitTop))]
+[unit? (make-pred-ty -UnitTop)]
 
 ;; Section 9.1
 [exn:misc:match? (-> Univ B)]
@@ -1309,34 +1316,34 @@
                   (make-ValuesDots (list (-result b)) c 'c))
               (make-ValuesDots (list (-result (Un a b))) c 'c))))]
 [call-with-continuation-barrier (-poly (a) (-> (-> a) a))]
-[continuation-prompt-available? (-> (make-Prompt-TagTop) B)]
+[continuation-prompt-available? (-> -Prompt-TagTop B)]
 [continuation?
  (asym-pred Univ B (-PS (-is-type 0 top-func) -tt))]
-[continuation-prompt-tag? (make-pred-ty (make-Prompt-TagTop))]
+[continuation-prompt-tag? (make-pred-ty -Prompt-TagTop)]
 [dynamic-wind (-poly (a) (-> (-> ManyUniv) (-> a) (-> ManyUniv) a))]
 
 ;; Section 10.5 (Continuation Marks)
 ;; continuation-marks needs type for continuations as other
 ;; possible first argument
 [continuation-marks
- (->opt (Un (-val #f) -Thread) [(make-Prompt-TagTop)] -Cont-Mark-Set)]
-[current-continuation-marks (->opt [(make-Prompt-TagTop)] -Cont-Mark-Set)]
+ (->opt (Un (-val #f) -Thread) [-Prompt-TagTop] -Cont-Mark-Set)]
+[current-continuation-marks (->opt [-Prompt-TagTop] -Cont-Mark-Set)]
 [continuation-mark-set->list
  (-poly (a)
         (cl->*
          (->opt -Cont-Mark-Set (make-Continuation-Mark-Keyof a)
-                [(make-Prompt-TagTop)] (-lst a))
-         (->opt -Cont-Mark-Set Univ [(make-Prompt-TagTop)] (-lst Univ))))]
+                [-Prompt-TagTop] (-lst a))
+         (->opt -Cont-Mark-Set Univ [-Prompt-TagTop] (-lst Univ))))]
 [continuation-mark-set->list*
  (-poly (a b)
         (cl->*
          (->opt -Cont-Mark-Set
                 (-lst (make-Continuation-Mark-Keyof a))
-                [b (make-Prompt-TagTop)]
+                [b -Prompt-TagTop]
                 (-lst (-vec (Un a b))))
          (->opt -Cont-Mark-Set
                 (-lst Univ)
-                [Univ (make-Prompt-TagTop)]
+                [Univ -Prompt-TagTop]
                 (-lst (-vec Univ)))))]
 [continuation-mark-set-first
  (-poly (a b)
@@ -1344,12 +1351,12 @@
          (-> (-opt -Cont-Mark-Set) (make-Continuation-Mark-Keyof a)
              (-opt a))
          (->opt (-opt -Cont-Mark-Set) (make-Continuation-Mark-Keyof a)
-                [b (make-Prompt-TagTop)]
+                [b -Prompt-TagTop]
                 (Un a b))
-         (->opt (-opt -Cont-Mark-Set) Univ [Univ (make-Prompt-TagTop)] Univ)))]
+         (->opt (-opt -Cont-Mark-Set) Univ [Univ -Prompt-TagTop] Univ)))]
 [call-with-immediate-continuation-mark
  (-poly (a) (->opt Univ (-> Univ a) [Univ] a))]
-[continuation-mark-key? (make-pred-ty (make-Continuation-Mark-KeyTop))]
+[continuation-mark-key? (make-pred-ty -Continuation-Mark-KeyTop)]
 [continuation-mark-set? (make-pred-ty -Cont-Mark-Set)]
 [make-continuation-mark-key
  (-poly (a) (->opt [-Symbol] (make-Continuation-Mark-Keyof a)))]
@@ -1438,7 +1445,7 @@
 
 ;; Section 11.2.2
 [make-channel (-poly (a) (-> (-channel a)))]
-[channel? (make-pred-ty (make-ChannelTop))]
+[channel? (make-pred-ty -ChannelTop)]
 [channel-get (-poly (a) ((-channel a) . -> . a))]
 [channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))]
 [channel-put (-poly (a) ((-channel a) a . -> . -Void))]
@@ -1468,7 +1475,7 @@
                  [a a] b)))]
 
 ;; Section 11.3.1 (Thread Cells)
-[thread-cell? (make-pred-ty (make-ThreadCellTop))]
+[thread-cell? (make-pred-ty -ThreadCellTop)]
 [make-thread-cell (-poly (a) (->opt a [Univ] (-thread-cell a)))]
 [thread-cell-ref (-poly (a) (-> (-thread-cell a) a))]
 [thread-cell-set! (-poly (a) (-> (-thread-cell a) a -Void))]
@@ -1755,7 +1762,7 @@
 
 ;; Section 12.8
 [syntax-recertify (-poly (a) (-> (-Syntax a) (-Syntax Univ) -Inspector Univ (-Syntax a)))]
-[syntax-debug-info (-poly (a) (->opt (-Syntax a) [(-opt -Integer) Univ] -HashTop))]
+[syntax-debug-info (-poly (a) (->opt (-Syntax a) [(-opt -Integer) Univ] -HashtableTop))]
 
 ;; Section 12.9
 [expand (-> Univ (-Syntax Univ))]
@@ -2495,23 +2502,23 @@
 [make-sibling-inspector (->opt [-Inspector] -Inspector)]
 [current-inspector (-Param -Inspector -Inspector)]
 
-[struct-info (-> Univ (-values (list (-opt (make-StructTypeTop)) B)))]
+[struct-info (-> Univ (-values (list (-opt -StructTypeTop) B)))]
 [struct-type-info
  (-poly (a)
    (cl->*
     (-> (make-StructType a)
         (-values (list Sym -Nat -Nat (-> a -Nat Univ)
                        (-> a -Nat (Un) -Void) (-lst -Nat)
-                       (-opt (make-StructTypeTop)) B)))
-    (-> (make-StructTypeTop)
+                       (-opt -StructTypeTop) B)))
+    (-> -StructTypeTop
         (-values (list Sym -Nat -Nat top-func top-func (-lst -Nat)
-                       (-opt (make-StructTypeTop)) B)))))]
-[struct-type-make-constructor (-> (make-StructTypeTop) top-func)]
+                       (-opt -StructTypeTop) B)))))]
+[struct-type-make-constructor (-> -StructTypeTop top-func)]
 [struct-type-make-predicate
  (-poly (a)
    (cl->*
     (-> (make-StructType a) (make-pred-ty a))
-    (-> (make-StructTypeTop) (-> Univ B))))]
+    (-> -StructTypeTop (-> Univ B))))]
 [object-name (-> Univ Univ)]
 
 ;; Section 14.9 (Code Inspectors)
@@ -3069,8 +3076,8 @@
                    (cl->*
                     (->acc (list (-pair a b)) b (list -cdr))
                     (->* (list (-lst a)) (-lst a))))]
-[unsafe-vector-length ((make-VectorTop) . -> . -Index)]
-[unsafe-vector*-length ((make-VectorTop) . -> . -Index)]
+[unsafe-vector-length (-VectorTop . -> . -Index)]
+[unsafe-vector*-length (-VectorTop . -> . -Index)]
 [unsafe-struct-ref top-func]
 [unsafe-struct*-ref top-func]
 [unsafe-struct-set! top-func]
diff --git a/typed-racket-lib/typed-racket/base-env/base-special-env.rkt b/typed-racket-lib/typed-racket/base-env/base-special-env.rkt
index ca2ca67c..7bf85f47 100644
--- a/typed-racket-lib/typed-racket/base-env/base-special-env.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-special-env.rkt
@@ -4,14 +4,15 @@
 ;; that are expanded into by Racket macros
 (require
  "../utils/utils.rkt"
- (only-in "../rep/type-rep.rkt" make-StructTypeTop)
+ (only-in "../rep/type-rep.rkt" -StructTypeTop)
  racket/promise
  string-constants/string-constant
  racket/private/kw racket/file racket/port syntax/parse racket/path
  (for-template (only-in racket/private/kw kw-expander-proc kw-expander-impl)
                racket/base racket/file racket/port racket/path racket/list)
  (env init-envs)
- (rename-in (types abbrev numeric-tower union) [make-arr* make-arr])
+ (rename-in (types abbrev numeric-tower)
+            [make-arr* make-arr])
  (for-syntax racket/base syntax/parse
              (only-in racket/syntax syntax-local-eval)))
 (provide make-template-identifier)
@@ -121,67 +122,67 @@
   [(make-template-identifier 'default-in-hash 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a b)]
-                [(-HashTop) (-seq Univ Univ)]))]
+                [(-HashtableTop) (-seq Univ Univ)]))]
   [(make-template-identifier 'default-in-hash-keys 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-hash-values 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq b)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-hash-pairs 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq (-pair a b))]
-                [(-HashTop) (-seq (-pair Univ Univ))]))]
+                [(-HashtableTop) (-seq (-pair Univ Univ))]))]
   [(make-template-identifier 'default-in-immutable-hash 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a b)]
-                [(-HashTop) (-seq Univ Univ)]))]
+                [(-HashtableTop) (-seq Univ Univ)]))]
   [(make-template-identifier 'default-in-immutable-hash-keys 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-immutable-hash-values 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq b)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-immutable-hash-pairs 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq (-pair a b))]
-                [(-HashTop) (-seq (-pair Univ Univ))]))]
+                [(-HashtableTop) (-seq (-pair Univ Univ))]))]
   [(make-template-identifier 'default-in-mutable-hash 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a b)]
-                [(-HashTop) (-seq Univ Univ)]))]
+                [(-HashtableTop) (-seq Univ Univ)]))]
   [(make-template-identifier 'default-in-mutable-hash-keys 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-mutable-hash-values 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq b)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-mutable-hash-pairs 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq (-pair a b))]
-                [(-HashTop) (-seq (-pair Univ Univ))]))]
+                [(-HashtableTop) (-seq (-pair Univ Univ))]))]
   [(make-template-identifier 'default-in-weak-hash 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a b)]
-                [(-HashTop) (-seq Univ Univ)]))]
+                [(-HashtableTop) (-seq Univ Univ)]))]
   [(make-template-identifier 'default-in-weak-hash-keys 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq a)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-weak-hash-values 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq b)]
-                [(-HashTop) (-seq Univ)]))]
+                [(-HashtableTop) (-seq Univ)]))]
   [(make-template-identifier 'default-in-weak-hash-pairs 'racket/private/for)
    (-poly (a b)
           (cl-> [((-HT a b)) (-seq (-pair a b))]
-                [(-HashTop) (-seq (-pair Univ Univ))]))]
+                [(-HashtableTop) (-seq (-pair Univ Univ))]))]
   ;; in-port
   [(make-template-identifier 'in-port 'racket/private/for)
    (-poly (a)
@@ -246,9 +247,9 @@
   [(make-template-identifier 'prop:named-keyword-procedure 'racket/private/kw)
    -Struct-Type-Property]
   [(make-template-identifier 'struct:keyword-procedure/arity-error 'racket/private/kw)
-   (make-StructTypeTop)]
+   -StructTypeTop]
   [(make-template-identifier 'struct:keyword-method/arity-error 'racket/private/kw)
-   (make-StructTypeTop)]
+   -StructTypeTop]
   ;; from the expansion of `define-runtime-path`
   [(make-template-identifier 'path-of 'racket/runtime-path)
    (-> -Path -Path)]
diff --git a/typed-racket-lib/typed-racket/base-env/base-structs.rkt b/typed-racket-lib/typed-racket/base-env/base-structs.rkt
index 449b37cf..ad66f0fd 100644
--- a/typed-racket-lib/typed-racket/base-env/base-structs.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-structs.rkt
@@ -3,7 +3,7 @@
 (require
  "../utils/utils.rkt"
  (rep type-rep)
- (types abbrev numeric-tower union)
+ (types abbrev numeric-tower)
  (typecheck tc-structs)
  ;;For tests
  (prefix-in k: '#%kernel))
diff --git a/typed-racket-lib/typed-racket/base-env/base-types.rkt b/typed-racket-lib/typed-racket/base-env/base-types.rkt
index 534bf3c5..16e21e70 100644
--- a/typed-racket-lib/typed-racket/base-env/base-types.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-types.rkt
@@ -1,7 +1,8 @@
 #lang s-exp "type-env-lang.rkt"
 
-(require "../types/abbrev.rkt" "../types/union.rkt"
-         "../types/numeric-tower.rkt" "../rep/type-rep.rkt")
+(require "../types/abbrev.rkt"
+         "../types/numeric-tower.rkt"
+         "../rep/type-rep.rkt")
 
 [Complex -Number]
 [Number -Number]
@@ -119,14 +120,14 @@
 [ChannelTop -ChannelTop]
 [Async-ChannelTop -Async-ChannelTop]
 [VectorTop -VectorTop]
-[HashTableTop -HashTop]
+[HashTableTop -HashtableTop]
 [MPairTop -MPairTop]
-[Thread-CellTop -Thread-CellTop]
+[Thread-CellTop -ThreadCellTop]
 [Prompt-TagTop -Prompt-TagTop]
 [Continuation-Mark-KeyTop -Continuation-Mark-KeyTop]
-[Struct-TypeTop (make-StructTypeTop)]
-[ClassTop (make-ClassTop)]
-[UnitTop (make-UnitTop)]
+[Struct-TypeTop -StructTypeTop]
+[ClassTop -ClassTop]
+[UnitTop -UnitTop]
 [Keyword -Keyword]
 [Thread -Thread]
 [Resolved-Module-Path -Resolved-Module-Path]
diff --git a/typed-racket-lib/typed-racket/base-env/env-lang.rkt b/typed-racket-lib/typed-racket/base-env/env-lang.rkt
index cdc7c13d..d357eb3c 100644
--- a/typed-racket-lib/typed-racket/base-env/env-lang.rkt
+++ b/typed-racket-lib/typed-racket/base-env/env-lang.rkt
@@ -5,7 +5,7 @@
 (require (for-syntax racket/base syntax/parse)
          (utils tc-utils)
          (env init-envs)
-         (types abbrev numeric-tower union prop-ops))
+         (types abbrev numeric-tower prop-ops))
 
 (define-syntax (-#%module-begin stx)
   (define-syntax-class clause
@@ -29,4 +29,4 @@
          require
          (except-out (all-from-out racket/base) #%module-begin)
          types rep private utils
-         (types-out abbrev numeric-tower union prop-ops))
+         (types-out abbrev numeric-tower prop-ops))
diff --git a/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt b/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
index b9593b38..571eb6b5 100644
--- a/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
+++ b/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
@@ -12,7 +12,7 @@
                      racket/base
                      syntax/parse
                      syntax/stx)
-         (for-syntax (types abbrev numeric-tower union prop-ops)))
+         (for-syntax (types abbrev numeric-tower prop-ops)))
 
 (provide type-environment
          (rename-out [-#%module-begin #%module-begin])
@@ -21,7 +21,7 @@
          (except-out (all-from-out racket/base) #%module-begin)
          (for-syntax (except-out (all-from-out racket/base) #%module-begin))
          types rep private utils
-         (for-syntax (types-out abbrev numeric-tower union prop-ops)))
+         (for-syntax (types-out abbrev numeric-tower prop-ops)))
 
 ;; syntax classes for type clauses in the type-environment macro
 (begin-for-syntax
diff --git a/typed-racket-lib/typed-racket/env/global-env.rkt b/typed-racket-lib/typed-racket/env/global-env.rkt
index 167fe02a..3f6d2496 100644
--- a/typed-racket-lib/typed-racket/env/global-env.rkt
+++ b/typed-racket-lib/typed-racket/env/global-env.rkt
@@ -21,8 +21,6 @@
          type-env-map
          type-env-for-each)
 
-(lazy-require ["../rep/type-rep.rkt" (Type? type-equal?)])
-
 ;; free-id-table from id -> type or Box[type]
 ;; where id is a variable, and type is the type of the variable
 ;; if the result is a box, then the type has not actually been defined, just registered
@@ -37,7 +35,7 @@
   (cond [(free-id-table-ref the-mapping id (lambda _ #f))
          => (lambda (e)
               (define t (if (box? e) (unbox e) e))
-              (unless (and (Type? t) (type-equal? t type))
+              (unless (equal? t type)
                 (tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t))
               (when (box? e)
                 (free-id-table-set! the-mapping id t)))]
@@ -51,7 +49,7 @@
          =>
          (λ (t) ;; it's ok to annotate with the same type
            (define t* (if (box? t) (unbox t) t))
-           (unless (and (Type? t*) (type-equal? type t*))
+           (unless (equal? type t*)
              (tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t*)))]
         [else (free-id-table-set! the-mapping id (box type))]))
 
diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt
index f5dc3eb2..70eb1d5e 100644
--- a/typed-racket-lib/typed-racket/env/init-envs.rkt
+++ b/typed-racket-lib/typed-racket/env/init-envs.rkt
@@ -3,19 +3,18 @@
 ;; Support for defining the initial TR environment
 
 (require "../utils/utils.rkt"
-         "../utils/tc-utils.rkt"
+         (utils tc-utils hset)
          "global-env.rkt"
          "type-name-env.rkt"
          "type-alias-env.rkt"
          "mvar-env.rkt"
          "signature-env.rkt"
-         (rename-in racket/private/sort [sort raw-sort])
          (rep core-rep type-rep
               prop-rep rep-utils
               object-rep values-rep
               free-variance)
          (for-syntax syntax/parse racket/base)
-         (types abbrev struct-table union utils)
+         (types abbrev struct-table utils)
          data/queue
          racket/dict racket/list racket/set racket/promise
          racket/match)
@@ -59,11 +58,11 @@
 
 ;; Compute for a given type how many times each type inside of it
 ;; is referenced
-(define (compute-popularity ty)
-  (when (Type? ty)
-    (hash-update! pop-table ty add1 0))
-  (when (walkable? ty)
-    (Rep-walk compute-popularity ty)))
+(define (compute-popularity x)
+  (when (Type? x)
+    (hash-update! pop-table x add1 0))
+  (when (Rep? x)
+    (Rep-for-each x compute-popularity)))
 
 (define (popular? ty)
   (> (hash-ref pop-table ty 0) 5))
@@ -91,22 +90,22 @@
   (λ (stx)
     (syntax-parse stx
       [(_ id)
-       #'(? Rep? (app (λ (v) (hash-ref predefined-type-table (Rep-seq v) #f))
+       #'(? Rep? (app (λ (v) (hash-ref predefined-type-table v #f))
                       (? values id)))])))
 
 ;; Helper for type->sexp
 (define (recur ty)
   (define (numeric? t) (match t [(Base: _ _ _ b) b] [(Value: (? number?)) #t] [_ #f]))
   (define (split-union ts)
-    (define-values (nums others) (partition numeric? ts))
-    (cond [(or (null? nums) (null? others))
-            ;; nothing interesting to do in this case
-            `(make-Union (list ,@(map type->sexp ts)))]
-           [else
-            ;; we do a little more work to hopefully save a bunch in serialization space
-            ;; if we get a hit in the predefined-type-table
-            `(simple-Un ,(type->sexp (apply Un nums))
-                        ,(type->sexp (apply Un others)))]))
+    (let ([ts (hset->list ts)])
+      (define-values (nums others) (partition numeric? ts))
+      (cond [(or (null? nums) (null? others))
+             ;; nothing interesting to do in this case
+             `(Un ,@(map type->sexp ts))]
+            [else
+             ;; we do a little more work to hopefully save a bunch in serialization space
+             ;; if we get a hit in the predefined-type-table
+             `(Un ,(type->sexp (apply Un nums)) ,(type->sexp (apply Un others)))])))
 
   (match ty
     [(In-Predefined-Table: id) id]
@@ -215,12 +214,12 @@
                    ,(object->sexp obj))]
     [(AnyValues: prop)
      `(make-AnyValues ,(prop->sexp prop))]
-    [(Union: (list (Value: vs) ...))
+    [(Union: (app hset->list (list (Value: vs) ...)))
      `(one-of/c ,@(for/list ([v (in-list vs)])
                     `(quote ,v)))]
     [(Union: elems) (split-union elems)]
     [(Intersection: elems)
-     `(make-Intersection (list ,@(map type->sexp elems)))]
+     `(make-Intersection (hset ,@(hset-map elems type->sexp)))]
     [(Name: stx 0 #t)
      `(-struct-name (quote-syntax ,stx))]
     [(Name: stx args struct?)
@@ -238,10 +237,9 @@
     [(Prefab: key flds)
      `(make-Prefab (quote ,key)
                    (list ,@(map type->sexp flds)))]
-    [(App: rator rands stx)
+    [(App: rator rands)
      `(make-App ,(type->sexp rator)
-                (list ,@(map type->sexp rands))
-                ,(and stx `(quote-syntax ,stx)))]
+                (list ,@(map type->sexp rands)))]
     [(Opaque: pred)
      `(make-Opaque (quote-syntax ,pred))]
     [(Refinement: parent pred)
@@ -344,7 +342,7 @@
 ;; Convert an object to an s-expression to eval
 (define (object->sexp obj)
   (match obj
-    [(Empty:) `(make-Empty)]
+    [(Empty:) `-empty-obj]
     [(Path: null (cons 0 arg))
      `(-arg-path ,arg)]
     [(Path: null (cons depth arg))
diff --git a/typed-racket-lib/typed-racket/env/mvar-env.rkt b/typed-racket-lib/typed-racket/env/mvar-env.rkt
index 03ccb027..afe4c95d 100644
--- a/typed-racket-lib/typed-racket/env/mvar-env.rkt
+++ b/typed-racket-lib/typed-racket/env/mvar-env.rkt
@@ -1,13 +1,13 @@
 #lang racket/base
 
-(require syntax/id-table racket/dict)
+(require syntax/id-table)
 
 (provide mvar-env register-mutated-var is-var-mutated?)
 
 (define mvar-env (make-free-id-table))
 
 (define (register-mutated-var id)
-  (dict-set! mvar-env id #t))
+  (free-id-table-set! mvar-env id #t))
 
 (define (is-var-mutated? id)
-  (dict-ref mvar-env id #f))
+  (free-id-table-ref mvar-env id #f))
diff --git a/typed-racket-lib/typed-racket/env/signature-env.rkt b/typed-racket-lib/typed-racket/env/signature-env.rkt
index 05b21ac0..57c45014 100644
--- a/typed-racket-lib/typed-racket/env/signature-env.rkt
+++ b/typed-racket-lib/typed-racket/env/signature-env.rkt
@@ -8,8 +8,7 @@
          lookup-signature
          lookup-signature/check
          signature-env-map
-         signature-env-for-each
-         with-signature-env/extend)
+         signature-env-for-each)
 
 (require syntax/id-table
          racket/match
@@ -21,7 +20,7 @@
          (rep type-rep))
 
 ;; initial signature environment
-(define signature-env (make-parameter (make-immutable-free-id-table)))
+(define signature-env (make-free-id-table))
 
 ;; register-signature! : identifier? Signature? -> Void
 ;; adds a mapping from the given identifier to the given signature
@@ -30,30 +29,19 @@
   (when (lookup-signature id)
     (tc-error/fields "duplicate signature definition"
                      "identifier" (syntax-e id)))
-  (signature-env (free-id-table-set (signature-env) id sig)))
-
-
-(define-syntax-rule (with-signature-env/extend ids sigs . b)
-  (let ([ids* ids]
-        [sigs* sigs])
-    (define new-env 
-      (for/fold ([env (signature-env)])
-                ([id (in-list ids*)]
-                 [sig (in-list sigs*)])
-        (free-id-table-set env id sig)))
-    (parameterize ([signature-env new-env]) . b)))
+  (free-id-table-set! signature-env id sig))
 
 ;; Iterate over the signature environment forcing the types of bindings
 ;; in each signature
 (define (finalize-signatures!)
-  (sorted-dict-for-each (signature-env) (λ (id sig) (force sig)) id<))
+  (sorted-dict-for-each signature-env (λ (id sig) (force sig)) id<))
 
 ;; lookup-signature : identifier? -> (or/c #f Signature?)
 ;; look up the signature corresponding to the given identifier
 ;; in the signature environment
 (define (lookup-signature id)
   (cond
-    [(free-id-table-ref (signature-env) id #f) => force]
+    [(free-id-table-ref signature-env id #f) => force]
     [else #f]))
 
 ;; lookup-signature/check : identifier? -> Signature?
@@ -67,7 +55,7 @@
                        #:stx id)))
 
 (define (signature-env-map f)
-  (sorted-dict-map (signature-env) (λ (id sig) (f id (force sig))) id<))
+  (sorted-dict-map signature-env (λ (id sig) (f id (force sig))) id<))
 
 (define (signature-env-for-each f)
-  (sorted-dict-for-each (signature-env) (λ (id sig) (f id (force sig))) id<))
+  (sorted-dict-for-each signature-env (λ (id sig) (f id (force sig))) id<))
diff --git a/typed-racket-lib/typed-racket/env/type-alias-helper.rkt b/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
index 5f7e851e..05f23edb 100644
--- a/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
+++ b/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
@@ -3,7 +3,7 @@
 ;; This module provides helper functions for type aliases
 
 (require "../utils/utils.rkt"
-         (utils tarjan tc-utils)
+         (utils tarjan tc-utils hset)
          (env type-alias-env type-name-env)
          (rep type-rep)
          (private parse-type)
@@ -57,11 +57,12 @@
 ;;
 (define (check-type-alias-contractive id type)
   (define/match (check type)
-    [((Union: elems)) (andmap check elems)]
+    [((Union: elems)) (for/and ([elem (in-hset elems)]) (check elem))]
+    [((Intersection: elems)) (for/and ([elem (in-hset elems)]) (check elem))]
     [((Name/simple: name-id))
      (and (not (free-identifier=? name-id id))
           (check (resolve-once type)))]
-    [((App: rator rands stx))
+    [((App: rator rands))
      (and (check rator) (check rands))]
     [((Mu: _ body)) (check body)]
     [((Poly: names body)) (check body)]
diff --git a/typed-racket-lib/typed-racket/env/type-env-structs.rkt b/typed-racket-lib/typed-racket/env/type-env-structs.rkt
index bc0e0d6a..758ba8eb 100644
--- a/typed-racket-lib/typed-racket/env/type-env-structs.rkt
+++ b/typed-racket-lib/typed-racket/env/type-env-structs.rkt
@@ -20,14 +20,9 @@
              (free-id-table-map (env-types e)
                                 (λ (id ty) (format "[~a ∈ ~a]" id ty)))
              (env-props e)
-             (free-id-table-map (env-types e)
+             (free-id-table-map (env-aliases e)
                                 (λ (id ty) (format "[~a ≡ ~a]" id ty))))))
 
-;; when interning is removed, the -empty-obj
-;; shorthand will be visible in this file. until
-;; then this will do -amk
-(define -empty-obj (make-Empty))
-
 (provide/cond-contract
   [env? predicate/c]
   [env-set-type (env? identifier? Type? . -> . env?)]
diff --git a/typed-racket-lib/typed-racket/env/type-name-env.rkt b/typed-racket-lib/typed-racket/env/type-name-env.rkt
index 4ac7169d..7a343f4d 100644
--- a/typed-racket-lib/typed-racket/env/type-name-env.rkt
+++ b/typed-racket-lib/typed-racket/env/type-name-env.rkt
@@ -107,7 +107,7 @@
           [(or (not tvars) (null? tvars)) #t]
           [else
             (define free-vars (free-vars-hash (free-vars* type)))
-            (define variance (map (λ (v) (hash-ref free-vars v Constant)) tvars))
+            (define variance (map (λ (v) (hash-ref free-vars v variance:const)) tvars))
             (define old-variance (lookup-type-variance name))
 
             (register-type-variance! name variance)
@@ -117,5 +117,5 @@
 ;; Initialize variance of the given id to Constant for all type vars
 (define (add-constant-variance! name vars)
   (unless (or (not vars) (null? vars))
-    (register-type-variance! name (map (lambda (_) Constant) vars))))
+    (register-type-variance! name (map (lambda (_) variance:const) vars))))
 
diff --git a/typed-racket-lib/typed-racket/infer/constraints.rkt b/typed-racket-lib/typed-racket/infer/constraints.rkt
index 4ac4ac25..6efdcc26 100644
--- a/typed-racket-lib/typed-racket/infer/constraints.rkt
+++ b/typed-racket-lib/typed-racket/infer/constraints.rkt
@@ -1,11 +1,11 @@
 #lang racket/unit
 
 (require "../utils/utils.rkt"
-	 (types abbrev union subtype)
+	 (types abbrev subtype)
 	 racket/dict
-         "fail.rkt" "signatures.rkt" "constraint-structs.rkt"
-         racket/match
-         racket/list)
+     "fail.rkt" "signatures.rkt" "constraint-structs.rkt"
+     racket/match
+     racket/list)
 
 (import intersect^ dmap^)
 (export constraints^)
diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt
index 2099372b..e18ae4ee 100644
--- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt
+++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt
@@ -10,23 +10,21 @@
 (require "../utils/utils.rkt"
          (except-in
           (combine-in
-           (utils tc-utils)
+           (utils tc-utils hset)
            (rep free-variance type-rep prop-rep object-rep
                 values-rep rep-utils type-mask)
-           (types utils abbrev numeric-tower union subtype resolve
+           (types utils abbrev numeric-tower subtype resolve
                   substitute generalize prefab)
            (env index-env tvar-env))
           make-env -> ->* one-of/c)
          "constraint-structs.rkt"
          "signatures.rkt" "fail.rkt"
          "promote-demote.rkt"
-         racket/match racket/set
-         mzlib/etc
+         racket/match
          (contract-req)
          (for-syntax
            racket/base
            syntax/parse)
-         racket/dict
          racket/hash racket/list)
 
 (import dmap^ constraints^)
@@ -41,8 +39,7 @@
 
 ;; Type Type -> Pair<Seq, Seq>
 ;; construct a pair for the set of seen type pairs
-(define (seen-before s t)
-  (cons (Rep-seq s) (Rep-seq t)))
+(define seen-before cons)
 
 ;; Context, contains which type variables and indices to infer and which cannot be mentioned in
 ;; constraints.
@@ -88,27 +85,24 @@
 ;; Add the type pair to the set of seen type pairs
 (define/cond-contract (remember s t A)
   ((or/c AnyValues? Values/c ValuesDots?) (or/c AnyValues? Values/c ValuesDots?)
-   (listof (cons/c exact-nonnegative-integer?
-                   exact-nonnegative-integer?))
+   (listof (cons/c Rep? Rep?))
    . -> .
-   (listof (cons/c exact-nonnegative-integer?
-                   exact-nonnegative-integer?)))
+   (listof (cons/c Rep? Rep?)))
  (cons (seen-before s t) A))
 
 ;; Type Type -> Boolean
 ;; Check if a given type pair have been seen before
 (define/cond-contract (seen? s t cs)
   ((or/c AnyValues? Values/c ValuesDots?) (or/c AnyValues? Values/c ValuesDots?)
-   (listof (cons/c exact-nonnegative-integer?
-                   exact-nonnegative-integer?))
+   (listof (cons/c Rep? Rep?))
    . -> . any/c)
  (member (seen-before s t) cs))
 
 ;; (CMap DMap -> Pair<CMap, DMap>) CSet -> CSet
 ;; Map a function over a constraint set
 (define (map/cset f cset)
-  (% make-cset (for/list/fail ([(cmap dmap) (in-dict (cset-maps cset))])
-                 (f cmap dmap))))
+  (% make-cset (for/list/fail ([cmap/dmap (in-list (cset-maps cset))])
+                 (f (car cmap/dmap) (cdr cmap/dmap)))))
 
 ;; Symbol DCon -> DMap
 ;; Construct a dmap containing only a single mapping
@@ -192,7 +186,7 @@
 
 (define (List->end v)
   (match v
-    [(== -Null type-equal?) (null-end)]
+    [(== -Null) (null-end)]
     [(Listof: t) (uniform-end t)]
     [(ListDots: t dbound) (dotted-end t dbound)]
     [_ #f]))
@@ -430,7 +424,7 @@
   (define cs (current-seen))
   ;; if we've been around this loop before, we're done (for rec types)
   (cond
-    [(type-equal? S T) empty] ;; (CG-Refl)
+    [(equal? S T) empty] ;; (CG-Refl)
     [(Univ? T) empty] ;; CG-Top
     [(seen? S T cs) empty]
     [else
@@ -448,11 +442,12 @@
               (ValuesDots: (list (Result: _ psets _) ...) _ _))
           (AnyValues: q))
          (cset-join
-          (filter identity
-                  (for/list ([pset (in-list psets)])
-                    (match pset
-                      [(PropSet: p+ p-)
-                       (% cset-meet (cgen/prop context p+ q) (cgen/prop context p- q))]))))]
+          (for*/list ([pset (in-list psets)]
+                      [cs (in-value (% cset-meet
+                                       (cgen/prop context (PropSet-thn pset) q)
+                                       (cgen/prop context (PropSet-els pset) q)))]
+                      #:when cs)
+            cs))]
 
         ;; check all non Type? first so that calling subtype is safe
 
@@ -532,28 +527,28 @@
         ;; find *an* element of elems which can be made a subtype of T
         [((Intersection: ts) T)
          (cset-join
-          (for*/list ([t (in-list ts)]
+          (for*/list ([t (in-hset ts)]
                       [v (in-value (cg t T))]
                       #:when v)
             v))]
         
         ;; constrain S to be below *each* element of elems, and then combine the constraints
         [(S (Intersection: ts))
-         (define cs (for/list/fail ([ts (in-list ts)]) (cg S ts)))
+         (define cs (for/list/fail ([ts (in-hset ts)]) (cg S ts)))
          (and cs (cset-meet* (cons empty cs)))]
         
         ;; constrain *each* element of es to be below T, and then combine the constraints
         [((Union: es) T)
-         (define cs (for/list/fail ([e (in-list es)]) (cg e T)))
+         (define cs (for/list/fail ([e (in-hset es)]) (cg e T)))
          (and cs (cset-meet* (cons empty cs)))]
 
         ;; find *an* element of es which can be made to be a supertype of S
         ;; FIXME: we're using multiple csets here, but I don't think it makes a difference
         ;; not using multiple csets will break for: ???
         [(S (or (Union: es)
-                (and (Bottom:) (bind es '()))))
+                (and (Bottom:) (bind es (hset)))))
          (cset-join
-          (for*/list ([e (in-list es)]
+          (for*/list ([e (in-hset es)]
                       [v (in-value (cg S e))]
                       #:when v)
             v))]
@@ -608,7 +603,7 @@
         ;; To check that mutable pair is a sequence we check that the cdr is
         ;; both an mutable list and a sequence
         [((MPair: t1 t2) (Sequence: (list t*)))
-         (% cset-meet (cg t1 t*) (cg t2 T) (cg t2 (Un -Null (make-MPairTop))))]
+         (% cset-meet (cg t1 t*) (cg t2 T) (cg t2 (Un -Null -MPairTop)))]
         [((List: ts) (Sequence: (list t*)))
          (% cset-meet* (for/list/fail ([t (in-list ts)])
                                       (cg t t*)))]
@@ -653,9 +648,9 @@
 
 
         ;; resolve applications
-        [((App: _ _ _) _)
+        [((App: _ _) _)
          (% cg (resolve-once S) T)]
-        [(_ (App: _ _ _))
+        [(_ (App: _ _))
          (% cg S (resolve-once T))]
 
         ;; If the struct names don't match, try the parent of S
@@ -755,13 +750,21 @@
          ;; nothing worked, and we fail
          #f]))]))
 
-;; C : cset? - set of constraints found by the inference engine
-;; X : (listof symbol?) - type variables that must have entries
-;; Y : (listof symbol?) - index variables that must have entries
-;; R : Type? - result type into which we will be substituting
-(define/cond-contract (subst-gen C X Y R)
-  (cset? (listof symbol?) (listof symbol?) (or/c Values/c AnyValues? ValuesDots?)
-         . -> . (or/c #f substitution/c))
+;; C : set of constraints found by the inference engine
+;; X : type variables that must have entries
+;; Y : index variables that must have entries
+;; R : result type into which we will be substituting
+;; multiple-substitutions? : should we return one substitution (#f), or
+;; all the substitutions that were possible? (#t)
+;; NOTE: multiple substitutions are rare -- at the time of adding this
+;; parameter this feature is only used by the tc-app/list.
+;; NOTE: if multiple substitutions is #t, a list is returned,
+;; otherwise a single substitution (not in a list) is returned.
+(define/cond-contract (substs-gen C X Y R multiple-substitutions?)
+  (cset? (listof symbol?) (listof symbol?) (or/c Values/c AnyValues? ValuesDots?) boolean?
+         . -> . (or/c substitution/c
+                      (cons/c substitution/c
+                              (listof substitution/c))))
   (define var-hash (free-vars-hash (free-vars* R)))
   (define idx-hash (free-vars-hash (free-idxs* R)))
   ;; c : Constaint
@@ -769,15 +772,14 @@
   (define (constraint->type v variance)
     (match v
       [(c S T)
-       (evcase variance
-               [Constant S]
-               [Covariant S]
-               [Contravariant T]
-               [Invariant
-                (let ([gS (generalize S)])
-                  (if (subtype gS T)
-                      gS
-                      S))])]))
+       (match variance
+         [(? variance:const?) S]
+         [(? variance:co?) S]
+         [(? variance:contra?) T]
+         [(? variance:inv?) (let ([gS (generalize S)])
+                             (if (subtype gS T)
+                                 gS
+                                 S))])]))
 
   ;; Since we don't add entries to the empty cset for index variables (since there is no
   ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint
@@ -787,46 +789,50 @@
     (hash-union
      (for/hash ([v (in-list Y)]
                 #:unless (hash-has-key? S v))
-       (let ([var (hash-ref idx-hash v Constant)])
+       (let ([var (hash-ref idx-hash v variance:const)])
          (values v
-                 (evcase var
-                         [Constant (i-subst null)]
-                         [Covariant (i-subst null)]
-                         [Contravariant (i-subst/starred null Univ)]
-                         ;; TODO figure out if there is a better subst here
-                         [Invariant (i-subst null)]))))
+                 (match var
+                   [(? variance:const?) (i-subst null)]
+                   [(? variance:co?) (i-subst null)]
+                   [(? variance:contra?) (i-subst/starred null Univ)]
+                   ;; TODO figure out if there is a better subst here
+                   [(? variance:inv) (i-subst null)]))))
      S))
-  (match (car (cset-maps C))
-    [(cons cmap (dmap dm))
-     (let* ([subst (hash-union
-                    (for/hash ([(k dc) (in-hash dm)])
-                      (define (c->t c) (constraint->type c (hash-ref idx-hash k Constant)))
-                      (values
-                       k
-                       (match dc
-                         [(dcon fixed #f)
-                          (i-subst (map c->t fixed))]
-                         [(or (dcon fixed rest) (dcon-exact fixed rest))
-                          (i-subst/starred
-                           (map c->t fixed)
-                           (c->t rest))]
-                         [(dcon-dotted fixed dc dbound)
-                          (i-subst/dotted
-                           (map c->t fixed)
-                           (c->t dc)
-                           dbound)])))
-                    (for/hash ([(k v) (in-hash cmap)])
-                      (values k (t-subst (constraint->type v (hash-ref var-hash k Constant))))))]
-            [subst (for/fold ([subst subst]) ([v (in-list X)])
-                     (let ([entry (hash-ref subst v #f)])
-                       ;; Make sure we got a subst entry for a type var
-                       ;; (i.e. just a type to substitute)
-                       ;; If we don't have one, there are no constraints on this variable
-                       (if (and entry (t-subst? entry))
-                           subst
-                           (hash-set subst v (t-subst Univ)))))])
-       ;; verify that we got all the important variables
-       (extend-idxs subst))]))
+  (define (build-subst m)
+    (match m
+      [(cons cmap (dmap dm))
+       (let* ([subst (hash-union
+                      (for/hash ([(k dc) (in-hash dm)])
+                        (define (c->t c) (constraint->type c (hash-ref idx-hash k variance:const)))
+                        (values
+                         k
+                         (match dc
+                           [(dcon fixed #f)
+                            (i-subst (map c->t fixed))]
+                           [(or (dcon fixed rest) (dcon-exact fixed rest))
+                            (i-subst/starred
+                             (map c->t fixed)
+                             (c->t rest))]
+                           [(dcon-dotted fixed dc dbound)
+                            (i-subst/dotted
+                             (map c->t fixed)
+                             (c->t dc)
+                             dbound)])))
+                      (for/hash ([(k v) (in-hash cmap)])
+                        (values k (t-subst (constraint->type v (hash-ref var-hash k variance:const))))))]
+              [subst (for/fold ([subst subst]) ([v (in-list X)])
+                       (let ([entry (hash-ref subst v #f)])
+                         ;; Make sure we got a subst entry for a type var
+                         ;; (i.e. just a type to substitute)
+                         ;; If we don't have one, there are no constraints on this variable
+                         (if (and entry (t-subst? entry))
+                             subst
+                             (hash-set subst v (t-subst Univ)))))])
+         ;; verify that we got all the important variables
+         (extend-idxs subst))]))
+  (if multiple-substitutions?
+      (map build-subst (cset-maps C))
+      (build-subst (car (cset-maps C)))))
 
 ;; context : the context of what to infer/not infer
 ;; S : a list of types to be the subtypes of T
@@ -858,11 +864,13 @@
 ;; just return a boolean result
 (define infer
  (let ()
-  (define/cond-contract (infer X Y S T R [expected #f])
+  (define/cond-contract (infer X Y S T R [expected #f] #:multiple? [multiple-substitutions? #f])
     (((listof symbol?) (listof symbol?) (listof Type?) (listof Type?)
       (or/c #f Values/c ValuesDots?))
-     ((or/c #f Values/c AnyValues? ValuesDots?))
-     . ->* . (or/c boolean? substitution/c))
+     ((or/c #f Values/c AnyValues? ValuesDots?)
+      #:multiple? boolean?)
+     . ->* . (or/c #f substitution/c (cons/c substitution/c
+                                             (listof substitution/c))))
     (define ctx (context null X Y ))
     (define expected-cset
       (if expected
@@ -871,7 +879,10 @@
     (and expected-cset
          (let* ([cs (cgen/list ctx S T #:expected-cset expected-cset)]
                 [cs* (% cset-meet cs expected-cset)])
-           (and cs* (if R (subst-gen cs* X Y R) #t)))))
+           (and cs* (cond
+                      [R (substs-gen cs* X Y R multiple-substitutions?)]
+                      [else #t])))))
+  ;(trace infer)
   infer)) ;to export a variable binding and not syntax
 
 ;; like infer, but T-var is the vararg type:
@@ -905,4 +916,12 @@
    #:return-unless cs #f
    (define m (cset-meet cs expected-cset))
    #:return-unless m #f
-   (subst-gen m X (list dotted-var) R)))
+   (substs-gen m X (list dotted-var) R #f)))
+
+
+;(trace subst-gen)
+;(trace cgen)
+;(trace cgen/list)
+;(trace cgen/arr)
+;(trace cgen/seq)
+
diff --git a/typed-racket-lib/typed-racket/infer/intersect.rkt b/typed-racket-lib/typed-racket/infer/intersect.rkt
index b24bf069..e6f4c3fa 100644
--- a/typed-racket-lib/typed-racket/infer/intersect.rkt
+++ b/typed-racket-lib/typed-racket/infer/intersect.rkt
@@ -1,8 +1,9 @@
 #lang racket/unit
 
-(require "../utils/utils.rkt")
-(require (rep type-rep type-mask)
-         (types abbrev base-abbrev union subtype resolve overlap)
+(require "../utils/utils.rkt"
+         (utils hset)
+         (rep type-rep type-mask rep-utils)
+         (types abbrev base-abbrev subtype resolve overlap)
          "signatures.rkt"
          racket/match
          racket/set)
@@ -15,9 +16,6 @@
 ;;  a non-additive intersection computation defined below
 ;; (i.e. only parts of t1 will remain, no parts from t2 are added))
 (define (intersect t1 t2)
-  ;; build-type: build a type while propogating bottom
-  (define (build-type constructor . args)
-    (if (memf Bottom? args) -Bottom (apply constructor args)))
   (cond
     ;; we dispatch w/ Error first, because it behaves in
     ;; strange ways (e.g. it is ⊤ and ⊥ w.r.t subtyping) and
@@ -36,11 +34,11 @@
        (define (rec t1 t2) (intersect t1 t2 seen))
        (match* (t1 t2)
          ;; quick overlap check
-         [(_ _) #:when (disjoint-masks? (Type-mask t1) (Type-mask t2)) -Bottom]
+         [(_ _) #:when (disjoint-masks? (mask t1) (mask t2)) -Bottom]
       
          ;; already a subtype
-         [(t1 t2) #:when (subtype t1 t2) t1]
-         [(t1 t2) #:when (subtype t2 t1) t2]
+         [(_ _) #:when (subtype t1 t2) t1]
+         [(_ _) #:when (subtype t2 t1) t2]
 
      
          ;; polymorphic intersect
@@ -53,32 +51,32 @@
      
          ;; structural recursion on types
          [((Pair: a1 d1) (Pair: a2 d2))
-          (build-type -pair  (rec a1 a2) (rec d1 d2))]
+          (-pair (rec a1 a2) (rec d1 d2))]
          ;; FIXME: support structural updating for structs when structs are updated to
          ;; contain not only *if* they are polymorphic, but *which* fields are too
          ;;[((Struct: _ _ _ _ _ _)
          ;; (Struct: _ _ _ _ _ _))]
          [((Syntax: t1*) (Syntax: t2*))
-          (build-type -Syntax (rec t1* t2*))]
+          (-Syntax (rec t1* t2*))]
          [((Promise: t1*) (Promise: t2*))
-          (build-type -Promise (rec t1* t2*))]
+          (-Promise (rec t1* t2*))]
 
          [((Union: t1s) t2)
           (match t2
             ;; let's be consistent in slamming together unions
             ;; (i.e. if we don't do this dual traversal, the order the
             ;; unions are passed to 'intersect' can produces different
-            ;; albeit equivalent (modulo subtyping, we hope) answers)
-            [(Union: t2s) (apply Un (for*/list ([t1 (in-list t1s)]
-                                                [t2 (in-list t2s)])
-                                      (rec t1 t2)))]
-            [_ (apply Un (map (λ (t1) (rec t1 t2)) t1s))])]
-         [(t1 (Union: t2s)) (apply Un (map (λ (t2) (rec t1 t2)) t2s))]
+            ;; (albeit equivalent modulo subtyping, we believe) answers)
+            [(Union: t2s) (make-Union (for*/hset ([t1 (in-hset t1s)]
+                                                  [t2 (in-hset t2s)])
+                                                 (rec t1 t2)))]
+            [_ (Union-map t1s (λ (t1) (rec t1 t2)))])]
+         [(t1 (Union: t2s)) (Union-map t2s (λ (t2) (rec t1 t2)))]
 
          [((Intersection: t1s) t2)
-          (apply -unsafe-intersect (map (λ (t1) (rec t1 t2)) t1s))]
+          (apply -unsafe-intersect (hset-map t1s (λ (t1) (rec t1 t2))))]
          [(t1 (Intersection: t2s))
-          (apply -unsafe-intersect (map (λ (t2) (rec t1 t2)) t2s))]
+          (apply -unsafe-intersect (hset-map t2s (λ (t2) (rec t1 t2))))]
 
          ;; For resolvable types, we record the occurrence and save a back pointer
          ;; in 'seen'. Then, if this pair of types emerges again, we know that we are
@@ -166,10 +164,10 @@
       
       ;; unions
       [((Union: t1s) t2)
-       (apply Un (map (λ (t1) (restrict t1 t2 resolved)) t1s))]
+       (Union-map  t1s (λ (t1) (restrict t1 t2 resolved)))]
 
       [(t1 (Union: t2s))
-       (apply Un (map (λ (t2) (restrict t1 t2 resolved)) t2s))]
+       (Union-map t2s (λ (t2) (restrict t1 t2 resolved)))]
       
       ;; restrictions
       [((Intersection: t1s) t2)
diff --git a/typed-racket-lib/typed-racket/infer/promote-demote.rkt b/typed-racket-lib/typed-racket/infer/promote-demote.rkt
index 618a83ab..2cb61638 100644
--- a/typed-racket-lib/typed-racket/infer/promote-demote.rkt
+++ b/typed-racket-lib/typed-racket/infer/promote-demote.rkt
@@ -53,18 +53,17 @@
                     (and drest (cons (contra (car drest)) (cdr drest)))
                     (map contra kws))])]))
   (match cur
-    [(? structural? t)
-     (define mk (Rep-constructor t))
-     (apply mk (for/list ([t (in-list (Rep-values t))]
-                          [v (in-list (Type-variances t))])
-                 (cond
-                   [(eq? v Covariant) (co t)]
-                   [(eq? v Invariant)
+    [(app Rep-variances variances) #:when variances 
+     (define mk (Rep-constructor cur))
+     (apply mk (for/list ([t (in-list (Rep-values cur))]
+                          [v (in-list variances)])
+                 (match v
+                   [(? variance:co?) (co t)]
+                   [(? variance:inv?)
                     (if (V-in? V t)
                         (if change Univ -Bottom)
                         t)]
-                   [(eq? v Contravariant)
-                    (contra t)])))]
+                   [(? variance:contra?) (contra t)])))]
     [(Unit: imports exports init-depends t)
      (make-Unit (map co imports)
                 (map contra imports)
@@ -80,4 +79,4 @@
                                                (if change Univ -Bottom)
                                                t))
                                     elems))]
-    [_ (Rep-fold co cur)]))
+    [_ (Rep-fmap cur co)]))
diff --git a/typed-racket-lib/typed-racket/infer/signatures.rkt b/typed-racket-lib/typed-racket/infer/signatures.rkt
index 5c98a34d..8d19812d 100644
--- a/typed-racket-lib/typed-racket/infer/signatures.rkt
+++ b/typed-racket-lib/typed-racket/infer/signatures.rkt
@@ -36,7 +36,9 @@
                             ;; range
                             (or/c #f Values/c ValuesDots?))
                            ;; optional expected type
-                           ((or/c #f Values/c AnyValues? ValuesDots?))
+                           ((or/c #f Values/c AnyValues? ValuesDots?)
+                            ;; optional multiple substitutions?
+                            #:multiple? boolean?)
                            . ->* . any)]
    [cond-contracted infer/vararg ((;; variables from the forall
                                    (listof symbol?)
diff --git a/typed-racket-lib/typed-racket/optimizer/fixnum.rkt b/typed-racket-lib/typed-racket/optimizer/fixnum.rkt
index c4136966..cce4ee9a 100644
--- a/typed-racket-lib/typed-racket/optimizer/fixnum.rkt
+++ b/typed-racket-lib/typed-racket/optimizer/fixnum.rkt
@@ -5,7 +5,8 @@
          "../utils/utils.rkt"
          (for-template racket/base racket/fixnum racket/unsafe/ops)
          (for-syntax racket/base syntax/parse racket/syntax)
-         (types numeric-tower union)
+         (rep type-rep)
+         (types numeric-tower)
          (optimizer utils logging))
 
 (provide fixnum-expr fixnum-opt-expr)
diff --git a/typed-racket-lib/typed-racket/optimizer/float.rkt b/typed-racket-lib/typed-racket/optimizer/float.rkt
index a7ab9e7f..b457c148 100644
--- a/typed-racket-lib/typed-racket/optimizer/float.rkt
+++ b/typed-racket-lib/typed-racket/optimizer/float.rkt
@@ -5,7 +5,7 @@
          (for-template racket/base racket/flonum racket/unsafe/ops racket/math)
          "../utils/utils.rkt"
          (utils tc-utils)
-         (types numeric-tower union abbrev)
+         (types numeric-tower abbrev)
          (optimizer utils numeric-utils logging fixnum))
 
 (provide float-opt-expr float-arg-expr int-expr float-op)
diff --git a/typed-racket-lib/typed-racket/optimizer/number.rkt b/typed-racket-lib/typed-racket/optimizer/number.rkt
index 9ab369e1..27c50f46 100644
--- a/typed-racket-lib/typed-racket/optimizer/number.rkt
+++ b/typed-racket-lib/typed-racket/optimizer/number.rkt
@@ -4,7 +4,7 @@
          syntax/parse/experimental/specialize
          (for-template racket/base)
          "../utils/utils.rkt"
-         (types numeric-tower union)
+         (types abbrev numeric-tower)
          (optimizer utils logging))
 
 (provide number-opt-expr)
diff --git a/typed-racket-lib/typed-racket/optimizer/sequence.rkt b/typed-racket-lib/typed-racket/optimizer/sequence.rkt
index 1eb36f94..810c1f19 100644
--- a/typed-racket-lib/typed-racket/optimizer/sequence.rkt
+++ b/typed-racket-lib/typed-racket/optimizer/sequence.rkt
@@ -14,9 +14,9 @@
 
 
 (define-syntax-class/specialize string-expr
-  (typed-expr (λ (t) (type-equal? t -String))))
+  (typed-expr (λ (t) (equal? t -String))))
 (define-syntax-class/specialize bytes-expr
-  (typed-expr (λ (t) (type-equal? t -Bytes))))
+  (typed-expr (λ (t) (equal? t -Bytes))))
 (define-syntax-class/specialize list-expr
   (typed-expr (λ (t)
                  (match t
diff --git a/typed-racket-lib/typed-racket/optimizer/utils.rkt b/typed-racket-lib/typed-racket/optimizer/utils.rkt
index f0d7f2cd..a5fc8046 100644
--- a/typed-racket-lib/typed-racket/optimizer/utils.rkt
+++ b/typed-racket-lib/typed-racket/optimizer/utils.rkt
@@ -41,7 +41,7 @@
 ;; similar, but with type equality
 (define (isoftype? s t)
   (match (type-of s)
-         [(tc-result1: (== t type-equal?)) #t] [_ #f]))
+         [(tc-result1: (== t)) #t] [_ #f]))
 
 ;; generates a table matching safe to unsafe promitives
 (define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
diff --git a/typed-racket-lib/typed-racket/private/parse-type.rkt b/typed-racket-lib/typed-racket/private/parse-type.rkt
index 2d187822..3c0c24cb 100644
--- a/typed-racket-lib/typed-racket/private/parse-type.rkt
+++ b/typed-racket-lib/typed-racket/private/parse-type.rkt
@@ -4,11 +4,11 @@
 
 (require (rename-in "../utils/utils.rkt" [infer infer-in])
          (except-in (rep core-rep type-rep object-rep) make-arr)
-         (rename-in (types abbrev union utils prop-ops resolve
+         (rename-in (types abbrev utils prop-ops resolve
                            classes prefab signatures)
                     [make-arr* make-arr])
          (only-in (infer-in infer) intersect)
-         (utils tc-utils stxclass-util literal-syntax-class)
+         (utils tc-utils stxclass-util literal-syntax-class hset)
          syntax/stx (prefix-in c: (contract-req))
          syntax/parse racket/sequence
          (env tvar-env type-alias-env mvar-env
@@ -236,9 +236,9 @@
 (define-syntax-class path-elem
   #:description "path element"
   (pattern :car^
-           #:attr pe (make-CarPE))
+           #:attr pe -car)
   (pattern :cdr^
-           #:attr pe (make-CdrPE)))
+           #:attr pe -cdr))
 
 
 (define-syntax-class @
@@ -453,9 +453,10 @@
                          (define productive
                            (let loop ((ty t*))
                              (match ty
-                               [(Union: elems) (andmap loop elems)]
+                               [(Union: elems) (for/and ([elem (in-hset elems)]) (loop elem))]
+                               [(Intersection: elems) (for/and ([elem (in-hset elems)]) (loop elem))]
                                [(F: _) (not (equal? ty tvar))]
-                               [(App: rator rands stx)
+                               [(App: rator rands)
                                 (loop (resolve-app rator rands stx))]
                                [(Mu: _ body) (loop body)]
                                [(Poly: names body) (loop body)]
@@ -629,7 +630,10 @@
             [args (parse-types #'(arg args ...))])
          (resolve-app-check-error rator args stx)
          (match rator
-           [(? Name?) (make-App rator args stx)]
+           [(? Name?)
+            (define app (make-App rator args))
+            (register-app-for-checking! app stx)
+            app]
            [(Poly: _ _) (instantiate-poly rator args)]
            [(Mu: _ _) (loop (unfold rator) args)]
            [(Error:) Err]
@@ -904,8 +908,7 @@
                                         (unbox class-box)))
             ;; Ok to return Error here, since this type will
             ;; get reparsed in another pass
-            (make-Error)
-            ])]))
+            Err])]))
 
 ;; get-parent-inits : (U Type #f) -> Inits
 ;; Extract the init arguments out of a parent class type
diff --git a/typed-racket-lib/typed-racket/private/type-annotation.rkt b/typed-racket-lib/typed-racket/private/type-annotation.rkt
index 4136393b..664d8f37 100644
--- a/typed-racket-lib/typed-racket/private/type-annotation.rkt
+++ b/typed-racket-lib/typed-racket/private/type-annotation.rkt
@@ -4,7 +4,7 @@
          (rep type-rep)
          (utils tc-utils)
          (env global-env mvar-env)
-         (except-in (types subtype abbrev union utils generalize)
+         (except-in (types subtype abbrev utils generalize)
                     -> ->* one-of/c)
          (private parse-type syntax-properties)
          (contract-req)
@@ -29,7 +29,7 @@
                let-binding)
       (define t1 (parse-type/id stx prop))
       (define t2 (lookup-type stx (lambda () #f)))      
-      (when (and t2 (not (type-equal? t1 t2)))
+      (when (and t2 (not (equal? t1 t2)))
         (maybe-finish-register-type stx)
         (tc-error/delayed #:stx stx "Duplicate type annotation of ~a for ~a, previous was ~a" t1 (syntax-e stx) t2)))
     (if (syntax? prop)
diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt
index dcadef11..736da947 100644
--- a/typed-racket-lib/typed-racket/private/type-contract.rkt
+++ b/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -6,11 +6,10 @@
  "../utils/utils.rkt"
  syntax/parse
  (rep type-rep prop-rep object-rep)
- (utils tc-utils)
+ (utils tc-utils hset)
  (env type-name-env row-constraint-env)
  (rep core-rep rep-utils type-mask values-rep)
- (types resolve union utils printer)
- (only-in (types abbrev) -Dead-Code)
+ (types resolve utils printer match-expanders union)
  (prefix-in t: (types abbrev numeric-tower subtype))
  (private parse-type syntax-properties)
  racket/match racket/syntax racket/list
@@ -84,7 +83,7 @@
 (define (generate-contract-def stx cache sc-cache)
   (define prop (get-contract-def-property stx))
   (match-define (contract-def type-stx flat? maker? typed-side) prop)
-  (define *typ (if type-stx (parse-type type-stx) -Dead-Code))
+  (define *typ (if type-stx (parse-type type-stx) t:-Dead-Code))
   (define kind (if (and type-stx flat?) 'flat 'impersonator))
   (syntax-parse stx #:literals (define-values)
     [(define-values (n) _)
@@ -320,7 +319,7 @@
     [(_ sc-cache type-expr typed-side-expr match-clause ...)
      #'(let ([type type-expr]
              [typed-side typed-side-expr])
-         (define key (cons (Rep-seq type) typed-side))
+         (define key (cons type typed-side))
          (cond [(hash-ref sc-cache key #f)]
                [else
                 (define sc (match type match-clause ...))
@@ -359,7 +358,7 @@
         ;; We special case this rather than just resorting to standard
         ;; App resolution (see case below) because the resolution process
         ;; will make type->static-contract infinite loop.
-        [(App: (Name: name _ #f) _ _)
+        [(App: (Name: name _ #f) _)
          ;; Key with (cons name 'app) instead of just name because the
          ;; application of the Name is not necessarily the same as the
          ;; Name type alone
@@ -388,27 +387,29 @@
                                   (λ () (loop resolved-name 'both rv)))
                 (lookup-name-sc type typed-side)])]
         ;; Ordinary type applications or struct type names, just resolve
-        [(or (App: _ _ _) (Name/struct:)) (t->sc (resolve-once type))]
+        [(or (App: _ _) (Name/struct:)) (t->sc (resolve-once type))]
         [(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
         [(Bottom:) (or/sc)]
-        [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
-         (listof/sc (t->sc elem-ty))]
+        [(Listof: elem-ty) (listof/sc (t->sc elem-ty))]
         [(Base: sym cnt _ _)
          (flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)) sym)]
         [(Distinction: _ _ t) ; from define-new-subtype
          (t->sc t)]
         [(Refinement: par p?)
          (and/sc (t->sc par) (flat/sc p?))]
-        [(Union: elems)
-         (define-values (numeric non-numeric) (partition (λ (t) (eq? mask:number (Type-mask t))) elems))
-         (define numeric-sc (numeric-type->static-contract (apply Un numeric)))
-         (if numeric-sc
-             (apply or/sc numeric-sc (map t->sc non-numeric))
-             (apply or/sc (map t->sc elems)))]
+        [(? Union? t)
+         (match (normalize-type t)
+           [(Union: (app hset->list elems))
+            (define-values (numeric non-numeric) (partition (λ (t) (eq? mask:number (mask t))) elems))
+            (define numeric-sc (numeric-type->static-contract (apply Un numeric)))
+            (if numeric-sc
+                (apply or/sc numeric-sc (map t->sc non-numeric))
+                (apply or/sc (map t->sc elems)))]
+           [t (t->sc t)])]
         [(Intersection: ts)
          (define-values (chaperones/impersonators others)
            (for/fold ([cs/is null] [others null])
-                     ([elem (in-list ts)])
+                     ([elem (in-hset ts)])
              (define c (t->sc elem))
              (if (equal? flat-sym (get-max-contract-kind c))
                  (values cs/is (cons c others))
@@ -782,7 +783,8 @@
           (let loop ([ty b])
             (match (resolve ty)
               [(Function: _) #t]
-              [(Union: elems) (andmap loop elems)]
+              [(Union: elems) (for/and ([elem (in-hset elems)]) (loop elem))]
+              [(Intersection: elems) (for/or ([elem (in-hset elems)]) (loop elem))]
               [(Poly: _ body) (loop body)]
               [(PolyDots: _ body) (loop body)]
               [_ #f])))
@@ -820,7 +822,8 @@
           (let loop ([ty b])
             (match (resolve ty)
               [(Function: _) #t]
-              [(Union: elems) (andmap loop elems)]
+              [(Union: elems) (for/and ([elem (in-hset elems)]) (loop elem))]
+              [(Intersection: elems) (for/or ([elem (in-hset elems)]) (loop elem))]
               [(Poly: _ body) (loop body)]
               [(PolyDots: _ body) (loop body)]
               [_ #f])))
@@ -843,8 +846,8 @@
   (let/ec escape
     (let loop ([rep type])
       (match rep
-        [(App: (Name: _ _ #f) _ _) (escape #t)]
-        [_ (Rep-walk loop rep)]))
+        [(App: (Name: _ _ #f) _) (escape #t)]
+        [_ (Rep-for-each rep loop)]))
     #f))
 
 ;; True if the arities `arrs` are what we'd expect from a struct predicate
@@ -940,52 +943,52 @@
     ;; numeric special cases
     ;; since often-used types like Integer are big unions, this would
     ;; generate large contracts.
-    [(== t:-PosByte type-equal?) positive-byte/sc]
-    [(== t:-Byte type-equal?) byte/sc]
-    [(== t:-PosIndex type-equal?) positive-index/sc]
-    [(== t:-Index type-equal?) index/sc]
-    [(== t:-PosFixnum type-equal?) positive-fixnum/sc]
-    [(== t:-NonNegFixnum type-equal?) nonnegative-fixnum/sc]
+    [(== t:-PosByte) positive-byte/sc]
+    [(== t:-Byte) byte/sc]
+    [(== t:-PosIndex) positive-index/sc]
+    [(== t:-Index) index/sc]
+    [(== t:-PosFixnum) positive-fixnum/sc]
+    [(== t:-NonNegFixnum) nonnegative-fixnum/sc]
     ;; -NegFixnum is a base type
-    [(== t:-NonPosFixnum type-equal?) nonpositive-fixnum/sc]
-    [(== t:-Fixnum type-equal?) fixnum/sc]
-    [(== t:-PosInt type-equal?) positive-integer/sc]
-    [(== t:-Nat type-equal?) natural/sc]
-    [(== t:-NegInt type-equal?) negative-integer/sc]
-    [(== t:-NonPosInt type-equal?) nonpositive-integer/sc]
-    [(== t:-Int type-equal?) integer/sc]
-    [(== t:-PosRat type-equal?) positive-rational/sc]
-    [(== t:-NonNegRat type-equal?) nonnegative-rational/sc]
-    [(== t:-NegRat type-equal?) negative-rational/sc]
-    [(== t:-NonPosRat type-equal?) nonpositive-rational/sc]
-    [(== t:-Rat type-equal?) rational/sc]
-    [(== t:-FlonumZero type-equal?) flonum-zero/sc]
-    [(== t:-NonNegFlonum type-equal?) nonnegative-flonum/sc]
-    [(== t:-NonPosFlonum type-equal?) nonpositive-flonum/sc]
-    [(== t:-Flonum type-equal?) flonum/sc]
-    [(== t:-SingleFlonumZero type-equal?) single-flonum-zero/sc]
-    [(== t:-InexactRealZero type-equal?) inexact-real-zero/sc]
-    [(== t:-PosInexactReal type-equal?) positive-inexact-real/sc]
-    [(== t:-NonNegSingleFlonum type-equal?) nonnegative-single-flonum/sc]
-    [(== t:-NonNegInexactReal type-equal?) nonnegative-inexact-real/sc]
-    [(== t:-NegInexactReal type-equal?) negative-inexact-real/sc]
-    [(== t:-NonPosSingleFlonum type-equal?) nonpositive-single-flonum/sc]
-    [(== t:-NonPosInexactReal type-equal?) nonpositive-inexact-real/sc]
-    [(== t:-SingleFlonum type-equal?) single-flonum/sc]
-    [(== t:-InexactReal type-equal?) inexact-real/sc]
-    [(== t:-RealZero type-equal?) real-zero/sc]
-    [(== t:-PosReal type-equal?) positive-real/sc]
-    [(== t:-NonNegReal type-equal?) nonnegative-real/sc]
-    [(== t:-NegReal type-equal?) negative-real/sc]
-    [(== t:-NonPosReal type-equal?) nonpositive-real/sc]
-    [(== t:-Real type-equal?) real/sc]
-    [(== t:-ExactNumber type-equal?) exact-number/sc]
-    [(== t:-InexactComplex type-equal?) inexact-complex/sc]
-    [(== t:-Number type-equal?) number/sc]
-    [(== t:-ExtFlonumZero type-equal?) extflonum-zero/sc]
-    [(== t:-NonNegExtFlonum type-equal?) nonnegative-extflonum/sc]
-    [(== t:-NonPosExtFlonum type-equal?) nonpositive-extflonum/sc]
-    [(== t:-ExtFlonum type-equal?) extflonum/sc]
+    [(== t:-NonPosFixnum) nonpositive-fixnum/sc]
+    [(== t:-Fixnum) fixnum/sc]
+    [(== t:-PosInt) positive-integer/sc]
+    [(== t:-Nat) natural/sc]
+    [(== t:-NegInt) negative-integer/sc]
+    [(== t:-NonPosInt) nonpositive-integer/sc]
+    [(== t:-Int) integer/sc]
+    [(== t:-PosRat) positive-rational/sc]
+    [(== t:-NonNegRat) nonnegative-rational/sc]
+    [(== t:-NegRat) negative-rational/sc]
+    [(== t:-NonPosRat) nonpositive-rational/sc]
+    [(== t:-Rat) rational/sc]
+    [(== t:-FlonumZero) flonum-zero/sc]
+    [(== t:-NonNegFlonum) nonnegative-flonum/sc]
+    [(== t:-NonPosFlonum) nonpositive-flonum/sc]
+    [(== t:-Flonum) flonum/sc]
+    [(== t:-SingleFlonumZero) single-flonum-zero/sc]
+    [(== t:-InexactRealZero) inexact-real-zero/sc]
+    [(== t:-PosInexactReal) positive-inexact-real/sc]
+    [(== t:-NonNegSingleFlonum) nonnegative-single-flonum/sc]
+    [(== t:-NonNegInexactReal) nonnegative-inexact-real/sc]
+    [(== t:-NegInexactReal) negative-inexact-real/sc]
+    [(== t:-NonPosSingleFlonum) nonpositive-single-flonum/sc]
+    [(== t:-NonPosInexactReal) nonpositive-inexact-real/sc]
+    [(== t:-SingleFlonum) single-flonum/sc]
+    [(== t:-InexactReal) inexact-real/sc]
+    [(== t:-RealZero) real-zero/sc]
+    [(== t:-PosReal) positive-real/sc]
+    [(== t:-NonNegReal) nonnegative-real/sc]
+    [(== t:-NegReal) negative-real/sc]
+    [(== t:-NonPosReal) nonpositive-real/sc]
+    [(== t:-Real) real/sc]
+    [(== t:-ExactNumber) exact-number/sc]
+    [(== t:-InexactComplex) inexact-complex/sc]
+    [(== t:-Number) number/sc]
+    [(== t:-ExtFlonumZero) extflonum-zero/sc]
+    [(== t:-NonNegExtFlonum) nonnegative-extflonum/sc]
+    [(== t:-NonPosExtFlonum) nonpositive-extflonum/sc]
+    [(== t:-ExtFlonum) extflonum/sc]
     [else #f]))
 
 
diff --git a/typed-racket-lib/typed-racket/rep/core-rep.rkt b/typed-racket-lib/typed-racket/rep/core-rep.rkt
index d198279b..c05a6e87 100644
--- a/typed-racket-lib/typed-racket/rep/core-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/core-rep.rkt
@@ -20,7 +20,7 @@
          (for-syntax racket/base racket/syntax
                      syntax/parse))
 
-(provide Type Type-mask Type-subtype-cache Type?
+(provide Type Type?
          Prop Prop?
          Object Object? OptObject?
          PathElem PathElem?
@@ -29,22 +29,8 @@
          def-values
          def-prop
          def-object
-         def-pathelem
-         type-equal?
-         prop-equal?
-         object-equal?)
+         def-pathelem)
 
-(define-syntax type-equal? (make-rename-transformer #'eq?))
-(define-syntax prop-equal? (make-rename-transformer #'eq?))
-(define-syntax object-equal? (make-rename-transformer #'eq?))
-
-(provide-for-cond-contract name-ref/c)
-
-;; A Name-Ref is any value that represents an object.
-;; As an identifier, it represents a free variable in the environment
-;; As a pair, it represents a De Bruijn indexed bound variable (cons lvl arg-num)
-(define-for-cond-contract name-ref/c
-  (or/c identifier? (cons/c natural-number/c natural-number/c)))
 
 ;;************************************************************
 ;; Custom Printing Tools
@@ -55,32 +41,40 @@
                           print-prop print-object print-pathelem
                           print-values print-propset print-result)])
 
-;; Note: We eta expand the printer so it is not evaluated until needed.
-(define-syntax (struct/printer stx)
+;; comment out the above lazy-require and uncomment the following
+;; s-exp for simple debug printing of Rep structs
+#;(begin
+    (define (debug-printer rep port write?)
+      (display (cons (Rep-name rep) (Rep-values rep)) port))
+
+    (define print-type debug-printer)
+    (define print-prop debug-printer)
+    (define print-object debug-printer)
+    (define print-pathelem debug-printer)
+    (define print-values debug-printer)
+    (define print-propset debug-printer)
+    (define print-result debug-printer))
+
+(define-syntax (def-rep-class stx)
   (syntax-parse stx
     [(_ name:id
-        (flds:id ...)
-        printer:id)
+        #:printer printer:id
+        #:define-form def:id)
      (with-syntax ([mk (generate-temporary 'dont-use-me)])
-       (syntax/loc
+       (quasisyntax/loc
            stx
-         (struct name Rep (flds ...)
-           #:constructor-name mk
-           #:transparent
-           #:property prop:custom-print-quotable 'never
-           #:methods gen:custom-write
-           [(define (write-proc v port write?) (printer v port write?))])))]))
-
-
-(define-syntax (build-rep-definer syntax)
-  (syntax-parse syntax
-    [(_ class:id def-id:id)
-     (syntax/loc syntax
-       (define-syntax (def-id stx)
-         (syntax-parse stx
-           [(_ variant:id flds:expr . rst)
-            (syntax/loc stx
-              (def-rep variant flds [#:parent class] . rst))])))]))
+         (begin (struct name ()
+                  #:constructor-name mk
+                  #:transparent
+                  #:property prop:custom-print-quotable 'never
+                  #:methods gen:custom-write
+                  ;; Note: We eta expand the printer so it is not evaluated until needed.
+                  [(define (write-proc v port write?) (printer v port write?))])
+                (define-syntax (def stx)
+                  (syntax-parse stx
+                    [(_ variant:id flds:expr . rst)
+                     (syntax/loc stx
+                       (def-rep variant flds [#:parent name] . rst))])))))]))
 
 ;;
 ;; These structs are the 'meta-variables' of TR's internal grammar,
@@ -95,18 +89,9 @@
 ;;************************************************************
 ;; Types
 ;;************************************************************
-;;
-;;
-;; The 'mask' field that is used for quick-checking of certain
-;; properties. See type-mask.rkt for details.
 
-;; subtype-cache - for a given type τ, the subtype-cache
-;;    is a mapping from Type -> boolean, s.t. if
-;;    τ.subtype-cache[σ] = #t then τ <: σ holds, otherwise
-;;    if τ.subtype-cache[σ] = #f, then τ <: σ does not hold
-;; mask - the type mask for this type
-(struct/printer Type (subtype-cache mask) print-type)
-(build-rep-definer Type def-type)
+
+(def-rep-class Type #:printer print-type #:define-form def-type)
 
 ;;-----------------
 ;; Universal Type
@@ -114,15 +99,17 @@
 
 ;; the type of all well-typed terms
 ;; (called Any in user programs)
-(def-type Univ () #:base
-  [#:type-mask mask:unknown])
+(def-type Univ ()
+  [#:mask mask:unknown]
+  [#:singleton Univ])
 
 ;;-----------------
 ;; Bottom Type
 ;;-----------------
 
-(def-type Bottom () #:base
-  [#:type-mask mask:bottom])
+(def-type Bottom ()
+  [#:mask mask:bottom]
+  [#:singleton -Bottom])
 
 ;;************************************************************
 ;; Prop
@@ -130,13 +117,10 @@
 ;;
 ;; These convey learned information about program terms while
 ;; typechecking.
+(def-rep-class Prop #:printer print-prop #:define-form def-prop)
 
-(struct/printer Prop () print-prop)
-(build-rep-definer Prop def-prop)
-
-(def-prop TrueProp () #:base)
-
-(def-prop FalseProp () #:base)
+(def-prop TrueProp () [#:singleton -tt])
+(def-prop FalseProp () [#:singleton -ff])
 
 ;;************************************************************
 ;; Fields and Symbolic Objects
@@ -151,19 +135,17 @@
 ;;--------------
 
 ;; e.g. car, cdr, etc
-(struct/printer PathElem () print-pathelem)
-(build-rep-definer PathElem def-pathelem)
+(def-rep-class PathElem #:printer print-pathelem #:define-form def-pathelem)
 
 
 ;;----------
 ;; Objects
 ;;----------
-
-(struct/printer Object () print-object)
-(build-rep-definer Object def-object)
+(def-rep-class Object #:printer print-object #:define-form def-object)
 
 ;; empty object
-(def-rep Empty () #:base
+(def-rep Empty ()
+  [#:singleton -empty-obj]
   [#:extras
    #:property prop:custom-print-quotable 'never
    #:methods gen:custom-write
@@ -181,9 +163,7 @@
 ;;
 ;; Racket expressions can produce 0 or more values, 'SomeValues'
 ;; represents the general class of all these possibilities
-
-(struct/printer SomeValues () print-values)
-(build-rep-definer SomeValues def-values)
+(def-rep-class SomeValues #:printer print-values #:define-form def-values)
 
 
 ;;************************************************************
@@ -198,10 +178,9 @@
 
 
 (def-rep PropSet ([thn Prop?] [els Prop?])
-  [#:intern-key (cons (Rep-seq thn) (Rep-seq els))]
   [#:frees (f) (combine-frees (list (f thn) (f els)))]
-  [#:fold (f) (make-PropSet (f thn) (f els))]
-  [#:walk (f) (begin (f thn) (f els))]
+  [#:fmap (f) (make-PropSet (f thn) (f els))]
+  [#:for-each (f) (begin (f thn) (f els))]
   [#:extras
    #:property prop:custom-print-quotable 'never
    #:methods gen:custom-write
@@ -223,10 +202,9 @@
 
 
 (def-rep Result ([t Type?] [ps PropSet?] [o OptObject?])
-  [#:intern-key (list* (Rep-seq t) (Rep-seq ps) (Rep-seq o))]
   [#:frees (f) (combine-frees (list (f t) (f ps) (f o)))]
-  [#:fold (f) (make-Result (f t) (f ps) (f o))]
-  [#:walk (f) (begin (f t) (f ps) (f o))]
+  [#:fmap (f) (make-Result (f t) (f ps) (f o))]
+  [#:for-each (f) (begin (f t) (f ps) (f o))]
   [#:extras
    #:property prop:custom-print-quotable 'never
    #:methods gen:custom-write
diff --git a/typed-racket-lib/typed-racket/rep/free-variance.rkt b/typed-racket-lib/typed-racket/rep/free-variance.rkt
index e2ae489b..94c9d465 100644
--- a/typed-racket-lib/typed-racket/rep/free-variance.rkt
+++ b/typed-racket-lib/typed-racket/rep/free-variance.rkt
@@ -9,7 +9,7 @@
 
 (provide 
   ;; Variances
-  Covariant Contravariant Invariant Constant Dotted
+  variance:co variance:contra variance:inv variance:const variance:dotted
   variance? variance->binding
 
   ;; Construcing frees
@@ -23,12 +23,21 @@
   ;; Examining frees
   free-vars-hash
   free-vars-names
-  free-vars-has-key?)
+  free-vars-has-key?
+  variance:co?
+  variance:contra?
+  variance:inv?
+  variance:const?
+  variance:dotted?)
 
 
 ;; this file contains support for calculating the free variables/indexes of types
 ;; actual computation is done in rep-utils.rkt  and type-rep.rkt
-(define-values (variance? Covariant Contravariant Invariant Constant Dotted)
+(define-values (variance? variance:co
+                          variance:contra
+                          variance:inv
+                          variance:const
+                          variance:dotted)
   (let ()
     (define-struct Variance () #:transparent)
     (define-struct (Covariant Variance) () #:transparent)
@@ -39,19 +48,26 @@
     (define-struct (Dotted Variance) () #:transparent)
     (values Variance? (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
 
+(define (variance:co? x) (eq? x variance:co))
+(define (variance:contra? x) (eq? x variance:contra))
+(define (variance:inv? x) (eq? x variance:inv))
+(define (variance:const? x) (eq? x variance:const))
+(define (variance:dotted? x) (eq? x variance:dotted))
+
+
 (define (variance->binding var)
   (match var
-   ((== Covariant) #'Covariant)
-   ((== Contravariant) #'Contravariant)
-   ((== Invariant) #'Invariant)
-   ((== Constant) #'Constant)
-   ((== Dotted) #'Dotted)))
+    [(? variance:co?) #'variance:co]
+    [(? variance:contra?) #'variance:contra]
+    [(? variance:inv?) #'variance:inv]
+    [(? variance:const?) #'variance:const]
+    [(? variance:dotted?) #'variance:dotted]))
 
 (define (flip-variance v)
   (match v
-   ((== Covariant) Contravariant)
-   ((== Contravariant) Covariant)
-   (else v)))
+    [(? variance:co?) variance:contra]
+    [(? variance:contra?) variance:co]
+    [_ v]))
 
 ;;All of these are used internally
 ;;Only combined-frees is used externally
@@ -61,7 +77,7 @@
 
 
 ;; Base constructors
-(define (single-free-var name (variance Covariant))
+(define (single-free-var name [variance variance:co])
   (combined-frees (hasheq name variance) null))
 
 (define empty-free-vars 
@@ -89,13 +105,13 @@
 (define (make-invariant frees)
   (combined-frees
     (for/hasheq ([name (free-vars-names frees)])
-      (values name Invariant))
+      (values name variance:inv))
     null))
 
 (define (make-constant frees)
   (combined-frees
     (for/hasheq ([name (free-vars-names frees)])
-      (values name Constant))
+      (values name variance:const))
     null))
 
 ;; Listof[frees] -> frees
@@ -141,11 +157,11 @@
      (combine-hashes
       (for/list ((var (lookup-type-variance name)) (arg args))
         (free-vars-hash
-         (cond
-           [(eq? var Covariant) arg]
-           [(eq? var Contravariant) (flip-variances arg)]
-           [(eq? var Invariant) (make-invariant arg)]
-           [(eq? var Constant) (make-constant arg)]))))]))
+         (match var
+           [(? variance:co?) arg]
+           [(? variance:contra?) (flip-variances arg)]
+           [(? variance:inv?) (make-invariant arg)]
+           [(? variance:const?) (make-constant arg)]))))]))
 
 
 ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
@@ -154,11 +170,11 @@
   (define ((combine-var v) w)
     (cond
       [(eq? v w) v]
-      [(eq? v Dotted) w]
-      [(eq? w Dotted) v]
-      [(eq? v Constant) w]
-      [(eq? w Constant) v]
-      [else Invariant]))
+      [(variance:dotted? v) w]
+      [(variance:dotted? w) v]
+      [(variance:const? v) w]
+      [(variance:const? w) v]
+      [else variance:inv]))
     (for*/fold ([ht #hasheq()])
       ([old-free (in-list hashes)]
        [(sym var) (in-hash old-free)])
diff --git a/typed-racket-lib/typed-racket/rep/object-rep.rkt b/typed-racket-lib/typed-racket/rep/object-rep.rkt
index 70974a88..e183cc86 100644
--- a/typed-racket-lib/typed-racket/rep/object-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/object-rep.rkt
@@ -6,37 +6,43 @@
 ;; See "Logical Types for Untyped Languages" pg.3
 
 (require "../utils/utils.rkt"
+         racket/match
          "rep-utils.rkt"
          "core-rep.rkt"
          "free-variance.rkt"
          (env mvar-env)
          (contract-req))
 
-(provide -id-path)
+(provide -id-path name-ref=?)
+
+(def-pathelem CarPE () [#:singleton -car])
+(def-pathelem CdrPE () [#:singleton -cdr])
+(def-pathelem SyntaxPE () [#:singleton -syntax-e])
+(def-pathelem ForcePE () [#:singleton -force])
+(def-pathelem FieldPE () [#:singleton -field])
 
-(def-pathelem CarPE () #:base)
-(def-pathelem CdrPE () #:base)
-(def-pathelem SyntaxPE () #:base)
-(def-pathelem ForcePE () #:base)
-;; t is always a Name (can't put that into the contract b/c of circularity)
 (def-pathelem StructPE ([t Type?] [idx natural-number/c])
-  [#:intern-key (cons (Rep-seq t) idx)]
   [#:frees (f) (f t)]
-  [#:fold (f) (make-StructPE (f t) idx)]
-  [#:walk (f) (f t)])
-(def-pathelem FieldPE () #:base)
+  [#:fmap (f) (make-StructPE (f t) idx)]
+  [#:for-each (f) (f t)])
 
 (def-object Path ([elems (listof PathElem?)] [name name-ref/c])
-  [#:intern-key (cons (hash-name name) (map Rep-seq elems))]
   [#:frees (f)  (combine-frees (map f elems))]
-  [#:fold (f) (make-Path (map f elems) name)]
-  [#:walk (f) (for-each f elems)])
+  [#:fmap (f) (make-Path (map f elems) name)]
+  [#:for-each (f) (for-each f elems)]
+  [#:custom-constructor
+   (cond
+     [(identifier? name)
+      (if (is-var-mutated? name)
+          -empty-obj
+          (let ([name (normalize-id name)])
+            (intern-double-ref!
+             path-intern-table
+             name elems #:construct (make-Path elems name))))]
+     [else (intern-double-ref!
+            path-intern-table
+            name elems #:construct (make-Path elems name))])])
 
-(define (-id-path id)
-  (cond
-    [(identifier? id)
-     (if (is-var-mutated? id)
-         (make-Empty)
-         (make-Path null id))]
-    [else
-     (make-Path null id)]))
+(define path-intern-table (make-weak-hash))
+
+(define (-id-path name) (make-Path null name))
diff --git a/typed-racket-lib/typed-racket/rep/prop-rep.rkt b/typed-racket-lib/typed-racket/rep/prop-rep.rkt
index 5dd6a143..85c8b2a8 100644
--- a/typed-racket-lib/typed-racket/rep/prop-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/prop-rep.rkt
@@ -7,29 +7,31 @@
          "core-rep.rkt"
          "object-rep.rkt"
          racket/match
-         racket/lazy-require)
+         racket/lazy-require
+         (only-in racket/unsafe/ops unsafe-fx<=))
 
 (lazy-require
  ["../types/prop-ops.rkt" (-and -or)])
 
-(provide hash-name
-         -is-type
-         -not-type
-         AndProp?
-         AndProp:
-         AndProp-ps
-         OrProp?
-         OrProp:
-         OrProp-ps
-         (rename-out [make-OrProp* make-OrProp]
-                     [make-AndProp* make-AndProp]))
+(provide -is-type
+         -not-type)
 
 
 (def-prop TypeProp ([obj Object?] [type (and/c Type? (not/c Univ?) (not/c Bottom?))])
-  [#:intern-key (cons (Rep-seq obj) (Rep-seq type))]
   [#:frees (f) (combine-frees (list (f obj) (f type)))]
-  [#:fold (f) (-is-type (f obj) (f type))]
-  [#:walk (f) (begin (f obj) (f type))])
+  [#:fmap (f) (make-TypeProp (f obj) (f type))]
+  [#:for-each (f) (begin (f obj) (f type))]
+  [#:custom-constructor
+   (cond
+     [(Empty? obj) -tt]
+     [(Univ? type) -tt]
+     [(Bottom? type) -ff]
+     [else
+      (intern-double-ref!
+       tprop-intern-table
+       obj type #:construct (make-TypeProp obj type))])])
+
+(define tprop-intern-table (make-weak-hash))
 
 ;; Abbreviation for props
 ;; `i` can be an integer or name-ref/c for backwards compatibility
@@ -42,18 +44,23 @@
       [(exact-integer? i) (make-Path null (cons 0 i))]
       [(pair? i) (make-Path null i)]
       [else (-id-path i)]))
-  (cond
-    [(Empty? o) (make-TrueProp)]
-    [(Univ? t) (make-TrueProp)]
-    [(Bottom? t) (make-FalseProp)]
-    [else (make-TypeProp o t)]))
+  (make-TypeProp o t))
 
 (def-prop NotTypeProp ([obj Object?] [type (and/c Type? (not/c Univ?) (not/c Bottom?))])
-  [#:intern-key (cons (Rep-seq obj) (Rep-seq type))]
   [#:frees (f) (combine-frees (list (f obj) (f type)))]
-  [#:fold (f) (-not-type (f obj) (f type))]
-  [#:walk (f) (begin (f obj) (f type))])
+  [#:fmap (f) (-not-type (f obj) (f type))]
+  [#:for-each (f) (begin (f obj) (f type))]
+  [#:custom-constructor
+   (cond
+     [(Empty? obj) -tt]
+     [(Univ? type) -ff]
+     [(Bottom? type) -tt]
+     [else
+      (intern-double-ref!
+       ntprop-intern-table
+       obj type #:construct (make-NotTypeProp obj type))])])
 
+(define ntprop-intern-table (make-weak-hash))
 
 ;; Abbreviation for not props
 ;; `i` can be an integer or name-ref/c for backwards compatibility
@@ -66,36 +73,23 @@
       [(exact-integer? i) (make-Path null (cons 0 i))]
       [(pair? i) (make-Path null i)]
       [else (-id-path i)]))
-  (cond
-    [(Empty? o) (make-TrueProp)]
-    [(Bottom? t) (make-TrueProp)]
-    [(Univ? t) (make-FalseProp)]
-    [else (make-NotTypeProp o t)]))
+  (make-NotTypeProp o t))
 
-(def-prop OrProp ([ps (and/c (length>=/c 2)
-                             (listof (or/c TypeProp? NotTypeProp?)))])
-  #:no-provide
-  [#:intern-key (for/hash ([p (in-list ps)]) (values p #t))]
+(def-prop OrProp ([ps (listof (or/c TypeProp? NotTypeProp?))])
   [#:frees (f) (combine-frees (map f ps))]
-  [#:fold (f) (apply -or (map f ps))]
-  [#:walk (f) (for-each f ps)])
+  [#:fmap (f) (apply -or (map f ps))]
+  [#:for-each (f) (for-each f ps)]
+  [#:custom-constructor
+   (let ([ps (sort ps (λ (p q) (unsafe-fx<= (eq-hash-code p)
+                                            (eq-hash-code q))))])
+     (intern-single-ref!
+      orprop-intern-table
+      ps
+      #:construct (make-OrProp ps)))])
 
-(define (make-OrProp* ps)
-  (match ps
-    [(list) (make-FalseProp)]
-    [(list p) p]
-    [ps (make-OrProp ps)]))
+(define orprop-intern-table (make-weak-hash))
 
-(def-prop AndProp ([ps (and/c (length>=/c 2)
-                              (listof (or/c OrProp? TypeProp? NotTypeProp?)))])
-  #:no-provide
-  [#:intern-key (for/hash ([p (in-list ps)]) (values p #t))]
+(def-prop AndProp ([ps (listof (or/c OrProp? TypeProp? NotTypeProp?))])
   [#:frees (f) (combine-frees (map f ps))]
-  [#:fold (f) (apply -and (map f ps))]
-  [#:walk (f) (for-each f ps)])
-
-(define (make-AndProp* ps)
-  (match ps
-    [(list) (make-TrueProp)]
-    [(list p) p]
-    [ps (make-AndProp ps)]))
+  [#:fmap (f) (apply -and (map f ps))]
+  [#:for-each (f) (for-each f ps)])
diff --git a/typed-racket-lib/typed-racket/rep/rep-switch.rkt b/typed-racket-lib/typed-racket/rep/rep-switch.rkt
new file mode 100644
index 00000000..44656308
--- /dev/null
+++ b/typed-racket-lib/typed-racket/rep/rep-switch.rkt
@@ -0,0 +1,68 @@
+#lang racket/base
+
+(require "rep-utils.rkt"
+         racket/match
+         racket/unsafe/ops
+         (for-syntax racket/base
+                     syntax/parse
+                     racket/list
+                     racket/syntax))
+
+(provide define-switch)
+
+
+;; a macro for defining a switch function of the form:
+;; (define name (λ (a b ...) (switch (Rep-uid a) [switch-clauses ...])))
+;;
+;; This allows us to dispatch on the first arguments Rep-uid,
+;; which can be more efficient than long match statements with a case
+;; for large numbers of Reps (e.g. subtype)
+(define-syntax (define-switch stx)
+  (define-syntax-class (switch-clause arg other-args)
+    (pattern (((~datum case:) rep-name:id pattern:expr) . body)
+             #:with name #'rep-name
+             #:with idx (format-id #'rep-name "uid:~a" (syntax->datum #'rep-name))
+             #:with function
+             (with-syntax ([arg arg]
+                           [other-args other-args])
+               (syntax/loc #'body
+                 (λ (arg . other-args)
+                   (match arg
+                     [pattern . body]))))))
+  (syntax-parse stx
+    [(_ (name:id arg:id args:id ...)
+        (~var clause (switch-clause #'arg #'(args ...))) ...
+        [(~datum else:) . default])
+     (define name-symbols (map syntax->datum (syntax->list #'(clause.name ...))))
+     (unless (not (null? name-symbols))
+       (raise-syntax-error 'define-switch "switch cannot be null" stx))
+     (define sorted-name-symbols (sort name-symbols symbol<?))
+     (unless (eq? (first name-symbols) (first sorted-name-symbols))
+       (raise-syntax-error 'define-switch
+                           (format "expected ~a as the first case"
+                                   (first sorted-name-symbols))
+                           stx))
+     ;; we verify that the Rep cases appear in name-sorted order (so
+     ;; they are easier to find when browsing the code) and that there
+     ;; are no duplicate cases
+     (for ([cur (in-list (rest name-symbols))]
+           [cur-stx (in-list (rest (syntax->list #'(clause ...))))]
+           [cur* (in-list (rest sorted-name-symbols))]
+           [prev* (in-list sorted-name-symbols)]
+           [prev-stx (in-list (syntax->list #'(clause ...)))])
+       (when (eq? cur* prev*)
+         (raise-syntax-error 'define-switch
+                             (format "duplicate switch cases for ~a" prev*)
+                             prev-stx))
+       (unless (eq? cur cur*)
+         (raise-syntax-error 'define-switch
+                             (format "switch cases must be sorted! expected ~a but got ~a"
+                                     cur* cur)
+                             cur-stx)))
+     (syntax/loc stx
+       (define name
+         (let* ([default-fun (λ (arg args ...) . default)]
+                [switch-table (make-vector (get-uid-count) default-fun)])
+           (vector-set! switch-table clause.idx clause.function)
+           ...
+           (λ (arg args ...) ((unsafe-vector-ref switch-table (Rep-uid arg)) arg args ...)))))]))
diff --git a/typed-racket-lib/typed-racket/rep/rep-utils.rkt b/typed-racket-lib/typed-racket/rep/rep-utils.rkt
index 62de23f0..40bc5346 100644
--- a/typed-racket-lib/typed-racket/rep/rep-utils.rkt
+++ b/typed-racket-lib/typed-racket/rep/rep-utils.rkt
@@ -1,20 +1,20 @@
 #lang racket/base
 (require "../utils/utils.rkt"
-         "../utils/print-struct.rkt"
+         (utils tc-utils)
          
          racket/match
-         racket/generic
          (contract-req)
          "free-variance.rkt"
          "type-mask.rkt"
          racket/stxparam
          syntax/parse/define
          syntax/id-table
-         racket/unsafe/ops
+         racket/generic
+         (only-in racket/unsafe/ops unsafe-struct-ref)
          (for-syntax
+          (utils tc-utils)
           racket/match
           racket/list
-          racket/sequence
           (except-in syntax/parse id identifier keyword)
           racket/base
           syntax/struct
@@ -24,159 +24,225 @@
 
 
 (provide (all-defined-out)
+         get-uid-count
          (for-syntax var-name))
 
+
+;; Contract and Hash related helpers
+
 (provide-for-cond-contract length>=/c)
 
 (define-for-cond-contract ((length>=/c len) l)
   (and (list? l)
        (>= (length l) len)))
 
-;; seq: interning-generated serial number used to compare Reps (type<).
-;; free-vars: cached free type variables
-;; free-idxs: cached free dot sequence variables
-;; stx: originating syntax for error-reporting
-(struct Rep (seq free-vars free-idxs) #:transparent
-  #:methods gen:equal+hash
-  [(define (equal-proc x y recur)
-     (unsafe-fx= (Rep-seq x) (Rep-seq y)))
-   (define (hash-proc x recur) (Rep-seq x))
-   (define (hash2-proc x recur) (Rep-seq x))])
+(define-for-cond-contract name-ref/c
+  (or/c identifier?
+        (cons/c exact-integer? exact-integer?)))
 
-(define (Rep<? x y)
-  (unsafe-fx< (Rep-seq x) (Rep-seq y)))
+(define (name-ref=? x y)
+  (cond
+    [(identifier? x)
+     (and (identifier? y) (free-identifier=? x y))]
+    [else (equal? x y)]))
 
-;; prop:get-values
-(define-values (prop:Rep-name Rep-name)
-  (let-values ([(prop _ accessor) (make-struct-type-property 'named)])
-    (values prop accessor)))
+(define id-table (make-free-id-table))
+(define (normalize-id id)
+  (free-id-table-ref! id-table id id))
+
+(define (hash-id id)
+  (eq-hash-code (identifier-binding-symbol id)))
+
+(define (hash-name-ref name rec)
+  (if (identifier? name)
+      (hash-id name)
+      (rec name)))
 
 
-;; prop:get-values
-(define-values (prop:values-fun values-fun)
-  (let-values ([(prop _ accessor) (make-struct-type-property 'values)])
-    (values prop accessor)))
-
-;; Rep-values
-(define (Rep-values x)
-  ((values-fun x) x))
-
-;; prop:get-constructor
-(define-values (prop:constructor-fun Rep-constructor)
-  (let-values ([(prop _ accessor) (make-struct-type-property 'constructor)])
-    (values prop accessor)))
-
-;; structural type info for simple/straightforward types
-;; (i.e. we store the list of field variances)
-(define-values (prop:structural structural? Type-variances)
-  (make-struct-type-property 'structural))
-
-;; top type predicates
-(define-values (prop:top-type has-top-type? top-type-pred)
-  (make-struct-type-property 'top-type))
-
-;; prop:walk-fun
-(define-values (prop:walk-fun walkable? walk-fun)
-  (make-struct-type-property 'walk))
-;; Rep-walk
-(define (Rep-walk f x)
-  (define fun (walk-fun x))
-  (when (procedure? fun)
-    (fun f x)))
-
-;; prop:fold-fun
-(define-values (prop:fold-fun foldable? fold-fun)
-  (make-struct-type-property 'fold))
-
-;; Rep-fold
-(define (Rep-fold f x)
-  (define fun (fold-fun x))
-  (if (procedure? fun)
-      (fun f x)
-      x))
+;; This table maps a type to an identifier bound to the type.
+;; This allows us to avoid reconstructing the type when using
+;; it from its marshaled representation.
+;; The table is referenced in env/init-env.rkt
+;;
+;; For example, instead of marshalling a big union for `Integer`, we
+;; simply emit `-Integer`, which evaluates to the right type.
+(define predefined-type-table (make-hash))
+(define-syntax-rule (declare-predefined-type! id)
+  (hash-set! predefined-type-table id #'id))
+(provide predefined-type-table)
+(define-syntax-rule (define/decl id e)
+  (begin (define id e)
+         (declare-predefined-type! id)))
 
 
-;; Is this a type that can be a 'back-edge' into the type graph?
-;; (i.e. could blindly following this type lead to infinite recursion?)
-(define-values (prop:resolvable resolvable?)
-  (let-values ([(prop predicate _) (make-struct-type-property 'resolvable)])
-    (values prop predicate)))
+;; fetches an interned Rep based on the given _single_ key
+;; NOTE: the #:construct expression is only run if there
+;; is no interned copy, so we should avoid unnecessary
+;; allocation w/ this approach
+(define-simple-macro (intern-single-ref! table-exp:expr
+                                         key-exp:expr
+                                         #:construct val-exp:expr)
+  (let ([table table-exp])
+    (define key key-exp)
+    (define intern-box (hash-ref table key #f))
+    (cond
+      [(and intern-box (weak-box-value intern-box #f))]
+      [else
+       (define val val-exp)
+       (hash-set! table key (make-weak-box val))
+       val])))
+
+;; fetches an interned Rep based on the given _two_ keys
+;; see 'intern-single-ref!'
+(define-simple-macro (intern-double-ref! table:id
+                                         key-exp1:expr
+                                         key-exp2:expr
+                                         #:construct val-exp:expr)
+  (intern-single-ref! (hash-ref! table key-exp1 make-weak-hash)
+                      key-exp2
+                      #:construct val-exp))
+
+
+
+;; - - - - - - - - - - - -
+;; Rep Properties
+;; - - - - - - - - - - - -
+(define-generics Rep
+  ;; A symbol name for a Rep
+  ;; Rep-name : Rep -> symbol
+  (Rep-name Rep)
+  ;; The values this rep contains (see Rep-constructor).
+  ;; Rep-values : Rep -> (listof any/c)
+  (Rep-values Rep)
+  ;; is there a simple, structural description for the variances
+  ;; of this Rep's fields? (currently only used for 'structural' types,
+  ;; see type-rep.rkt
+  ;; Rep-constructor : Rep -> (any ... -> Rep)
+  (Rep-variances Rep)
+  ;; The intended constructor for this Rep.
+  ;; i.e. (equal? ((Rep-constructor rep) (Rep-values rep)) rep) = #t
+  ;; Rep-constructor : Rep -> (any ... -> Rep)
+  (Rep-constructor Rep)
+  ;; can this Rep contain free type variables?
+  ;; (i.e. 'F' types from rep/type-rep.rkt)
+  ;; Rep-free-ty-vars-fun : Rep -> free-vars
+  (Rep-free-vars Rep)
+  ;; can this Rep contain free dotted type variables (idxs)?
+  ;; (e.g. things like ListDots, etc rep/type-rep.rkt
+  ;;  which have an arity/structure which depends on instantiation)
+  ;; Rep-free-ty-idxs-fun : Rep -> free-dotted-vars
+  (Rep-free-idxs Rep)
+  ;; is this Rep mappable?
+  ;; (i.e. can we traverse it w/ applying a function to
+  ;;  the fields? a lá map for lists)
+  ;; Rep-fmap : Rep procedure -> Rep
+  (Rep-fmap Rep f)
+  ;; is this Rep walkable?
+  ;; (i.e. can we traverse it w/ some effectful function
+  ;;  a lá for-each for lists)
+  ;; Rep-walk-fun : Rep procedure -> void
+  (Rep-for-each Rep f))
+
+;; used internally when generating gen:Rep method definitions
+;; so that we don't have to mess around w/ 'define/generic'
+(define-syntax free-vars* (make-rename-transformer #'Rep-free-vars))
+(define-syntax free-idxs* (make-rename-transformer #'Rep-free-idxs))
+
+;; A variant-unique fixnum.
+;; Rep-uid : Rep -> fixnum
+(define-values (prop:uid Rep-uid)
+  (let-values ([(prop _ acc) (make-struct-type-property 'uid)])
+    (values prop acc)))
+
+
+(define-values (prop:mask raw-mask)
+  (let-values ([(prop _ acc) (make-struct-type-property 'mask)])
+    (values prop acc)))
+
+;; Type-mask : Rep -> fixnum
+(define-syntax-rule (mask rep)
+  (let ([mask (raw-mask rep)])
+    (if (procedure? mask)
+        (mask rep)
+        mask)))
 
 
 ;;************************************************************
 ;; Rep Declaration Syntax Classes
 ;;************************************************************
-(define (make-counter!)
-  (let ([state 0])
-    (λ () (begin0 state (set! state (unsafe-fx+ 1 state))))))
-
-(define count! (make-counter!))
-(define id-count! (make-counter!))
-
-(define identifier-table (make-free-id-table))
-
-(define (hash-id id)
-  (free-id-table-ref!
-   identifier-table
-   id
-   (λ () (let ([c (id-count!)])
-           (free-id-table-set! identifier-table id c)
-           c))))
-
-(define (hash-name name)
-  (if (identifier? name)
-      (hash-id name)
-      name))
+(define-values (next-uid! get-uid-count)
+  (let ([state 0]
+        [finalized? #f])
+    (values (λ () (if finalized?
+                      (int-err "next-uid! called after uid count finalized!")
+                      (begin0 state (set! state (add1 state)))))
+            (λ () (set! finalized? #t) state))))
 
 (begin-for-syntax
+  ;; defines a "rep transformer"
+  ;; These are functions defined to fold over Reps (e.g. Rep-fmap, Rep-for-each).
+  ;; Because they are defined within the definition of the struct, they bind the same
+  ;; identifiers which declare the Rep's fields to those same fields.
+  (define (rep-transform self f-id struct-fields body)
+    (with-syntax ([f-id f-id]
+                  [self self]
+                  [(fld ...) struct-fields]
+                  [body body])
+      #'(λ (self f-id)
+          (let ([fld (unsafe-struct-ref self (struct-field-index fld))] ...) . body))))
+  ;; like "rep-transform" but the folding function is fixed (e.g. free-vars)
+  (define (fixed-rep-transform self f-id fun struct-fields body)
+    (with-syntax ([transformer (rep-transform self f-id struct-fields body)]
+                  [self self]
+                  [fun fun])
+      #'(λ (self) (transformer self fun))))
   ;; #:frees definition parsing
-  (define-syntax-class freesspec
+  (define-syntax-class (freesspec struct-fields)
     #:attributes (free-vars free-idxs)
-    (pattern ([#:vars (f1) . vars-body]
-              [#:idxs (f2) . idxs-body])
-             #:with free-vars #'(let ([f1 Rep-free-vars]) . vars-body)
-             #:with free-idxs #'(let ([f2 Rep-free-idxs]) . idxs-body))
-    (pattern ((f:id) . body)
-             #:with free-vars #'(let ([f Rep-free-vars]) . body)
-             #:with free-idxs #'(let ([f Rep-free-idxs]) . body)))
-  ;; #:fold definition parsing
-  (define-syntax-class (walkspec name match-expdr struct-fields)
+    (pattern
+     ([#:vars (f1 (~optional (~seq #:self self1:id)
+                             #:defaults ([self1 (generate-temporary 'self)])))
+       . vars-body]
+      [#:idxs (f2 (~optional (~seq #:self self2:id)
+                             #:defaults ([self2 (generate-temporary 'self)])))
+       . idxs-body])
+     #:with free-vars (fixed-rep-transform #'self1 #'f1 #'free-vars* struct-fields #'vars-body)
+     #:with free-idxs (fixed-rep-transform #'self2 #'f2 #'free-idxs* struct-fields #'idxs-body))
+    (pattern
+     ((f:id (~optional (~seq #:self self:id)
+                       #:defaults ([self (generate-temporary 'self)])))
+      . body)
+     #:with free-vars (fixed-rep-transform #'self #'f #'free-vars* struct-fields #'body)
+     #:with free-idxs (fixed-rep-transform #'self #'f #'free-idxs* struct-fields #'body)))
+  (define-syntax-class (constructor-spec constructor-name raw-constructor-name struct-fields)
     #:attributes (def)
-    (pattern ((f:id) . body)
+    (pattern body
              #:with def
-             (with-syntax ([name name]
-                           [(flds ...) struct-fields]
-                           [mexpdr match-expdr])
-               #'(λ (f self)
-                   (match self
-                     [(mexpdr flds ...) . body]
-                     [_ (error 'Rep-walk "bad match in ~a's walk" (quote name))])))))
-  ;; #:map definition parsing
-  (define-syntax-class (foldspec name match-expdr struct-fields)
+             (with-syntax ([constructor-name constructor-name]
+                           [raw-constructor-name raw-constructor-name]
+                           [(struct-fields ...) struct-fields])
+               #'(define (constructor-name struct-fields ...)
+                   (let ([constructor-name raw-constructor-name])
+                     . body)))))
+  ;; definer parser for functions who operate on Reps. Fields are automatically bound
+  ;; to the struct-field id names in the body. An optional self argument can be specified.
+  (define-syntax-class (generic-transformer struct-fields)
     #:attributes (def)
     (pattern ((f:id (~optional (~seq #:self self:id)
                                #:defaults ([self (generate-temporary 'self)])))
               . body)
-             #:with def
-             (with-syntax ([name name]
-                           [(flds ...) struct-fields]
-                           [mexpdr match-expdr])
-               #'(λ (f self)
-                   (match self
-                     [(mexpdr flds ...) . body]
-                     [_ (error 'Rep-fold "bad match in ~a's fold" (quote name))])))))
+             #:with def (rep-transform #'self #'f struct-fields #'body)))
   ;; variant name parsing
   (define-syntax-class var-name
-    #:attributes (name raw-constructor constructor mexpdr pred)
+    #:attributes (name constructor raw-constructor match-expander predicate)
     (pattern name:id
-             #:with raw-constructor
-             ;; raw constructor should only be used by macros (hence the gensym)
-             (format-id #'name "raw-make-~a" (gensym (syntax-e #'name)))
              #:with constructor
              (format-id #'name "make-~a" (syntax-e #'name))
-             #:with mexpdr
+             ;; hidden constructor for use inside custom constructor defs
+             #:with raw-constructor (format-id #'name "raw-make-~a" (syntax-e #'name))
+             #:with match-expander
              (format-id #'name "~a:" (syntax-e #'name))
-             #:with pred
+             #:with predicate
              (format-id #'name "~a?" (syntax-e #'name))))
   ;; structure accessor parsing
   (define-syntax-class (fld-id struct-name)
@@ -208,31 +274,25 @@
       ;; options
       (~or
        ;; parent struct (if any)
-       (~optional (~optional [#:parent parent:id])
-                  #:defaults ([parent #'Rep]))
+       (~optional [#:parent parent:id])
        ;; base declaration (i.e. no fold/map)
        (~optional (~and #:base base?))
-       ;; All Reps are interned
-       (~optional [#:intern-key provided-intern-key])
        ;; #:frees spec (how to compute this Rep's free type variables)
-       (~optional [#:frees . frees-spec:freesspec])
-       ;; #:walk spec (how to traverse this structure for effect)
-       (~optional [#:walk . (~var walk-spec (walkspec #'var.name
-                                                      #'var.mexpdr
-                                                      #'(flds.ids ...)))])
+       (~optional [#:frees . (~var frees-spec (freesspec #'(flds.ids ...)))])
+       ;; #:for-each spec (how to traverse this structure for effect)
+       (~optional [#:for-each . (~var for-each-spec (generic-transformer #'(flds.ids ...)))])
        ;; #:fold spec (how to transform & fold this structure)
-       (~optional [#:fold . (~var fold-spec (foldspec #'var.name
-                                                      #'var.mexpdr
-                                                      #'(flds.ids ...)))])
-       (~optional [#:type-mask . type-mask-body])
-       ;; is this a Type w/ a Top type? (e.g. Vector --> VectorTop)
-       (~optional [#:top top-pred:id])
+       (~optional [#:fmap . (~var fold-spec (generic-transformer #'(flds.ids ...)))])
+       (~optional [#:mask . rep-mask-body])
+       (~optional [#:variances ((~literal list) variances ...)])
        ;; #:no-provide option (i.e. don't provide anything automatically)
-       (~optional (~and #:needs-resolving needs-resolving?))
-       ;; #:no-provide option (i.e. don't provide anything automatically)
-       (~optional (~and #:no-provide no-provide?))
-       ;; field variances (e.g. covariant/contravariant/etc) declarations
-       (~optional (~and [#:variances variances ...] structural))
+       (~optional (~and #:no-provide no-provide?-kw))
+       (~optional [#:singleton singleton:id])
+       (~optional [#:custom-constructor . (~var constr-def
+                                                (constructor-spec #'var.constructor
+                                                                  #'var.raw-constructor
+                                                                  #'(flds.ids ...)))])
+       (~optional (~and #:non-transparent non-transparent-kw))
        ;; #:extras to specify other struct properties in a per-definition manner
        (~optional [#:extras . extras]))
       ...)
@@ -242,141 +302,156 @@
      ;; - - - - - - - - - - - - - - -
      
      ;; build convenient boolean flags
-     (define is-a-type? (eq? 'Type (syntax-e #'parent)))
-     (define intern-key (if (attribute provided-intern-key)
-                            #'provided-intern-key
-                            #'#t))
-     ;; intern-key is required (when the number of fields is > 0)
-     (when (and (not (attribute provided-intern-key))
-                (> (length (syntax->list #'flds)) 0))
-       (raise-syntax-error 'def-rep "intern key specification required when the number of fields > 0"
+     (define is-a-type? (and (attribute parent) (eq? 'Type (syntax-e #'parent))))
+     ;; singletons cannot have fields or #:no-provide
+     (when (and (attribute singleton)
+                (or (attribute no-provide?-kw)
+                    (> (length (syntax->list #'flds)) 0)))
+       (raise-syntax-error 'def-rep "singletons cannot have fields or the #:no-provide option"
                            #'var))
-     ;; no frees, walk, or fold for #:base Reps
-     (when (and (attribute base?) (or (attribute frees-spec)
-                                      (attribute walk-spec)
-                                      (attribute fold-spec)))
-       (raise-syntax-error 'def-rep "base reps cannot have #:frees, #:walk, or #:fold"
+     (when (and (attribute base?)
+                (attribute singleton))
+       (raise-syntax-error 'def-rep "singletons are base by def, do not provide #:base option"
                            #'var))
-     ;; if non-base, frees, walk, and fold are required
-     (when (and (not (attribute base?))
+     ;; no frees, for-each, fold, or abs/inst for #:base Reps
+     (when (and (or (attribute base?)
+                    (attribute singleton))
+                (or (attribute frees-spec)
+                    (attribute for-each-spec)
+                    (attribute fold-spec)))
+       (raise-syntax-error 'def-rep "base reps and singletons cannot have #:frees, #:for-each, or #:fold"
+                           #'var))
+     ;; if non-base, frees, for-each, and fold are required
+     (when (and (not (or (attribute base?) (attribute singleton)))
                 (or (not (attribute frees-spec))
-                    (not (attribute walk-spec))
+                    (not (attribute for-each-spec))
                     (not (attribute fold-spec))))
-       (raise-syntax-error 'def-rep "non-base reps require #:frees, #:walk, and #:fold"
+       (raise-syntax-error 'def-rep "non-base reps require #:frees, #:for-each, and #:fold"
                            #'var))
-     ;; can't be structural and not a type
-     (when (and (not is-a-type?) (attribute structural))
-       (raise-syntax-error 'def-rep "only types can be structural" #'structural))
 
      ;; - - - - - - - - - - - - - - -
      ;; Let's build the definitions!
      ;; - - - - - - - - - - - - - - -
-     
      (with-syntax*
-       ([intern-key intern-key]
+       ([uid-id (format-id #'var.name "uid:~a" (syntax->datum #'var.name))]
+        [(parent ...) (if (attribute parent) #'(parent) #'())]
         ;; contract for constructor
-        [constructor-contract #'(-> flds.contracts ... var.pred)]
+        [constructor-contract #'(-> flds.contracts ... any)]
+        [constructor-name (if (attribute constr-def)
+                              #'var.raw-constructor
+                              #'var.constructor)]
+        [constructor-def (if (attribute constr-def)
+                             #'constr-def.def
+                             #'(begin))]
+        [(maybe-transparent ...) (if (attribute non-transparent-kw)
+                                     #'()
+                                     #'(#:transparent))]
         ;; match expander (skips 'meta' fields)
         [mexpdr-def
-         #`(define-match-expander var.mexpdr
+         #`(define-match-expander var.match-expander
              (λ (s)
                (syntax-parse s
-                 [(_ . pats)
-                  #,(if is-a-type? ;; skip Type-mask and subtype cache
-                        #'(syntax/loc s (var.name _ _ _ _ _ . pats))
-                        #'(syntax/loc s (var.name _ _ _ . pats)))])))]
+                 [(_ . pats) (syntax/loc s (var.name . pats))])))]
+        ;; Rep generic definitions
+        ;; -----------------------
         ;; free var/idx defs
-        [free-vars-def (cond
-                         [(attribute base?) #'empty-free-vars]
-                         [else #'frees-spec.free-vars])]
-        [free-idxs-def (cond
-                         [(attribute base?) #'empty-free-vars]
-                         [else #'frees-spec.free-idxs])]
-        ;; top type info
-        [(maybe-top-type-spec ...)
-         (if (attribute top-pred)
-             #'(#:property prop:top-type top-pred)
-             #'())]
-        ;; if it's a structural type, save its field variances
-        [(maybe-structural ...)
-         (if (attribute structural)
-             #'(#:property prop:structural (list variances ...))
-             #'())]
-        ;; an argument if we accept a type mask
-        [mask-arg (generate-temporary 'mask)]
-        ;; constructor w/ interning and Type-mask handeling if necessary
-        [constructor-def
+        [Rep-name-def
+         #'(define (Rep-name _) 'var.name)]
+        [Rep-values-def
+         #'(define (Rep-values rep)
+             (match rep
+               [(var.name flds.ids ...) (list flds.ids ...)]))]
+        [Rep-variances-def
          (cond
-           ;; non-Types don't need masks
-           [(not is-a-type?)
-            #'(define var.constructor
-                (let ([intern-table (make-hash)])
-                  (λ (flds.ids ...)
-                    (let ([key intern-key]
-                          [fail (λ () (let ([fvs free-vars-def]
-                                            [fis free-idxs-def])
-                                        (var.raw-constructor (count!) fvs fis flds.ids ...)))])
-                      (hash-ref! intern-table key fail)))))]
+           [(attribute variances)
+            #'(define (Rep-variances _)
+                (list variances ...))]
            [else
-            ;; Types have to provide Type-masks and subtype caches
-            #`(define var.constructor
-                (let ([intern-table (make-hash)])
-                  (λ (flds.ids ...)
-                    (let ([key intern-key]
-                          [fail (λ () (let ([fvs free-vars-def]
-                                            [fis free-idxs-def]
-                                            [mask-val #,(if (attribute type-mask-body)
-                                                            #'(let () . type-mask-body)
-                                                            #'mask:unknown)])
-                                        (var.raw-constructor (count!) fvs fis (make-hash) mask-val flds.ids ...)))])
-                      (hash-ref! intern-table key fail)))))])]
-        ;; walk def
-        [walk-def (cond
-                    [(attribute base?) #'#f]
-                    [else #'walk-spec.def])]
+            #'(define (Rep-variances _) #f)])]
+        [Rep-constructor-def
+         #'(define (Rep-constructor rep) var.constructor)]
+        ;; free var/idx defs
+        [Rep-free-vars-def
+         (cond
+           [(or (attribute base?)
+                (attribute singleton))
+            #'(define (Rep-free-vars _) empty-free-vars)]
+           [else #'(define Rep-free-vars frees-spec.free-vars)])]
+        [Rep-free-idxs-def
+         (cond
+           [(or (attribute base?)
+                (attribute singleton))
+            #'(define (Rep-free-idxs _) empty-free-vars)]
+           [else #'(define Rep-free-idxs frees-spec.free-idxs)])]
+        ;; for-each def
+        [Rep-for-each-def
+         (cond
+           [(or (attribute base?) (attribute singleton))
+            #'(define (Rep-for-each rep f) (void))]
+           [else #'(define Rep-for-each for-each-spec.def)])]
         ;; fold def
-        [fold-def (cond
-                    [(attribute base?) #'#f]
-                    [else #'fold-spec.def])]
-        ;; is this a type that needs resolving (e.g. Mu)
-        [(maybe-needs-resolving ...)
-         (if (attribute needs-resolving?)
-             #'(#:property prop:resolvable #t)
-             #'())]
+        [Rep-fmap-def
+         (cond
+           [(or (attribute base?) (attribute singleton))
+            #'(define (Rep-fmap rep f) rep)]
+           [else #'(define Rep-fmap fold-spec.def)])]
         ;; how do we pull out the values required to fold this Rep?
-        [values-def #'(match-lambda
-                        [(var.mexpdr flds.ids ...) (list flds.ids ...)])]
+        [rep-mask-body 
+         (cond
+           [(attribute rep-mask-body) #'(let () . rep-mask-body)]
+           [else #'mask:unknown])]
         ;; module provided defintions, if any
         [(provides ...)
          (cond
-           [(attribute no-provide?) #'()]
+           [(attribute no-provide?-kw) #'()]
            [else
-            #'((provide var.mexpdr var.pred flds.accessors ...)
+            #'((provide var.match-expander var.predicate flds.accessors ...)
                (provide/cond-contract (var.constructor constructor-contract)))])]
-        [(extra-defs ...) (if (attribute extras) #'extras #'())])
+        [(extra-defs ...) (if (attribute extras) #'extras #'())]
+        [struct-def #'(struct var.name parent ... (flds.ids ...)
+                        maybe-transparent ...
+                        #:constructor-name constructor-name
+                        #:property prop:uid uid-id
+                        #:property prop:mask rep-mask-body
+                        #:methods gen:Rep
+                        [Rep-name-def
+                         Rep-values-def
+                         Rep-constructor-def
+                         Rep-variances-def
+                         Rep-free-vars-def
+                         Rep-free-idxs-def
+                         Rep-for-each-def
+                         Rep-fmap-def]
+                        extra-defs ...)])
        ;; - - - - - - - - - - - - - - -
        ;; macro output
        ;; - - - - - - - - - - - - - - -
-       #'(begin
-           (struct var.name parent (flds.ids ...) #:transparent
-             #:constructor-name
-             var.raw-constructor
-             #:property prop:Rep-name (quote var.name)
-             #:property prop:constructor-fun
-             (λ (flds.ids ...) (var.constructor flds.ids ...))
-             #:property prop:values-fun
-             values-def
-             #:property prop:walk-fun
-             walk-def
-             #:property prop:fold-fun
-             fold-def
-             maybe-top-type-spec ...
-             maybe-structural ...
-             maybe-needs-resolving ...
-             extra-defs ...)
-           constructor-def
-           mexpdr-def
-           provides ...))]))
+       (cond
+         [(attribute singleton)
+          (syntax/loc stx
+            (begin
+              (define uid-id (next-uid!))
+              (define singleton
+                (let ()
+                  struct-def
+                  (var.constructor)))
+              (declare-predefined-type! singleton)
+              (define (var.predicate x) (eq? x singleton))
+              (define-match-expander var.match-expander
+                (λ (s)
+                  (syntax-parse s
+                    [(_) (syntax/loc s (? var.predicate))])))
+              (provide singleton var.predicate var.match-expander
+                       uid-id)))]
+         [else
+          (syntax/loc stx
+            (begin
+              (define uid-id (next-uid!))
+              struct-def
+              constructor-def
+              mexpdr-def
+              provides ...
+              (provide uid-id)))]))]))
 
 
 ;; macro for easily defining sets of types represented by fixnum bitfields
@@ -465,9 +540,3 @@
            ;; provide the bit variables (e.g. bits:Null)
            atoms.provide ...
            unions.provide ...))]))
-
-
-(provide
-  Rep-values
-  (rename-out [Rep-free-vars free-vars*]
-              [Rep-free-idxs free-idxs*]))
diff --git a/typed-racket-lib/typed-racket/rep/type-rep.rkt b/typed-racket-lib/typed-racket/rep/type-rep.rkt
index 442d0889..13baee72 100644
--- a/typed-racket-lib/typed-racket/rep/type-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/type-rep.rkt
@@ -6,18 +6,17 @@
 (require "../utils/utils.rkt")
 
 ;; TODO use contract-req
-(require (utils tc-utils)
+(require (utils tc-utils hset)
          "rep-utils.rkt"
          "core-rep.rkt"
          "values-rep.rkt"
          "type-mask.rkt"
          "object-rep.rkt"
          "free-variance.rkt"
-         racket/match racket/list racket/set
+         racket/match racket/list
+         syntax/id-table
          racket/contract
          racket/lazy-require
-         racket/promise
-         syntax/parse/define
          (for-syntax racket/base
                      racket/syntax
                      syntax/parse))
@@ -37,13 +36,16 @@
          PolyDots-n
          Class? Row? Row:
          free-vars*
-         type-equal?
          Name/simple: Name/struct:
          unfold
          Union?
-         Union:
          Union-elems
-         (rename-out [make-Union* make-Union]
+         Union-map
+         Un
+         resolvable?
+         (rename-out [instantiate instantiate-raw-type]
+                     [make-Union* make-Union]
+                     [Union:* Union:]
                      [Class:* Class:]
                      [Class* make-Class]
                      [Row* make-Row]
@@ -56,40 +58,48 @@
                      [PolyDots* make-PolyDots]
                      [PolyRow* make-PolyRow]
                      [Mu-body* Mu-body]
+                     [Mu-body Mu-body-unsafe]
                      [Poly-body* Poly-body]
                      [PolyDots-body* PolyDots-body]
                      [PolyRow-body* PolyRow-body]))
 
+(define (resolvable? x)
+  (or (Mu? x)
+      (Name? x)
+      (App? x)))
 
 (lazy-require
- ("../types/union.rkt" (Un))
  ("../types/overlap.rkt" (overlap?))
  ("../types/resolve.rkt" (resolve-app)))
 
-(define name-table (make-weak-hasheq))
+(define var-name-table (make-weak-hash))
 
 ;; Name = Symbol
 
 ;; Type is defined in rep-utils.rkt
 
 ;; this is ONLY used when a type error ocurrs
-(def-type Error () #:base)
+;; FIXME: add a safety so this type can literally
+;; ONLY be used when raising type errors, since
+;; it's a dangerous type to have accidently floating around
+;; as it is both Top and Bottom.
+(def-type Error () [#:singleton Err])
 
 ;; de Bruijn indexes - should never appear outside of this file
 ;; bound type variables
 ;; i is an nat
-(def-type B ([i natural-number/c]) #:base
-  [#:intern-key i])
+(def-type B ([i natural-number/c]) #:base)
 
 ;; free type variables
 ;; n is a Name
 (def-type F ([n symbol?])
-  [#:intern-key n]
   [#:frees
    [#:vars (_) (single-free-var n)]
    [#:idxs (_) empty-free-vars]]
-  [#:fold (_ #:self self) self]
-  [#:walk (_) (void)])
+  [#:fmap (_ #:self self) self]
+  [#:for-each (_) (void)])
+
+(define Name-table (make-free-id-table))
 
 ;; Name, an indirection of a type through the environment
 ;;
@@ -102,32 +112,25 @@
 (def-type Name ([id identifier?]
                 [args exact-nonnegative-integer?]
                 [struct? boolean?])
-  [#:intern-key (hash-id id)]
-  [#:frees (f) empty-free-vars]
-  [#:fold (_ #:self self) self]
-  [#:walk (_) (void)]
-  #:needs-resolving)
+  #:base
+  [#:custom-constructor
+   (free-id-table-ref! Name-table id (λ () (make-Name id args struct?)))])
 
 ;; rator is a type
 ;; rands is a list of types
-;; stx is the syntax of the pair of parens
 (def-type App ([rator Type?]
-               [rands (listof Type?)]
-               [stx (or/c #f syntax?)])
-  [#:intern-key (cons (Rep-seq rator) (map Rep-seq rands))]
+               [rands (listof Type?)])
   [#:frees (f)
    (match rator 
      [(Name: n _ _)
       (instantiate-frees n (map f rands))]
-     [_ (f (resolve-app rator rands stx))])]
-  [#:fold (f) (make-App (f rator)
-                        (map f rands)
-                        stx)]
-  [#:walk (f)
+     [_ (f (resolve-app rator rands))])]
+  [#:fmap (f) (make-App (f rator) (map f rands))]
+  [#:for-each (f)
    (f rator)
-   (for-each f rands)]
-  #:needs-resolving)
+   (for-each f rands)])
 
+(define base-table (make-hasheq))
 
 ;; name is a Symbol (not a Name)
 ;; contract is used when generating contracts from types
@@ -139,17 +142,20 @@
                 [contract syntax?]
                 [predicate procedure?]
                 [numeric? boolean?])
-  #:base
-  [#:intern-key name] 
-  [#:type-mask
-   (if numeric?
-       mask:number
-       (case name
-         [(Char) mask:char]
-         [(String) mask:string]
-         [(Void) mask:void]
-         [(Symbol) mask:symbol]
-         [else mask:base-other]))])
+  #:base 
+  [#:mask (match-lambda
+            [(Base: name _ _ numeric?)
+             (if numeric?
+                 mask:number
+                 (case name
+                   [(Char) mask:char]
+                   [(String) mask:string]
+                   [(Void) mask:void]
+                   [(Symbol) mask:symbol]
+                   [else mask:base-other]))])]
+  #:non-transparent
+  [#:custom-constructor
+   (hash-ref! base-table name (λ () (make-Base name contract predicate numeric?)))])
 
 
 ;;************************************************************
@@ -164,24 +170,26 @@
   (define-syntax-class (structural-flds frees)
     #:attributes (name variance fld-frees)
     (pattern [name:id #:covariant]
-             #:with variance #'Covariant
+             #:with variance #'variance:co
              #:with fld-frees #'(frees name))
     (pattern [name:id #:contravariant]
-             #:with variance #'Contravariant
+             #:with variance #'variance:contra
              #:with fld-frees #'(flip-variances (frees name)))
     (pattern [name:id #:invariant]
-             #:with variance #'Invariant
+             #:with variance #'variance:inv
              #:with fld-frees #'(make-invariant (frees name))))
   (syntax-parse stx
     [(_ name:var-name ((~var flds (structural-flds #'frees)) ...) . rst)
-     #'(def-rep name ([flds.name Type?] ...)
+     (quasisyntax/loc stx
+       (def-rep name ([flds.name Type?] ...)
          [#:parent Type]
-         [#:intern-key (list* (Rep-seq flds.name) ...)]
-         [#:variances flds.variance ...]
-         [#:frees (frees) (combine-frees (list flds.fld-frees ...))]
-         [#:fold (f) (name.constructor (f flds.name) ...)]
-         [#:walk (f) (f flds.name) ...]
-         . rst)]))
+         [#:frees (frees) . #,(if (= 1 (length (syntax->list #'(flds.name ...))))
+                                  #'(flds.fld-frees ...)
+                                  #'((combine-frees (list flds.fld-frees ...))))]
+         [#:fmap (f) (name.constructor (f flds.name) ...)]
+         [#:for-each (f) (f flds.name) ...]
+         [#:variances (list flds.variance ...)]
+         . rst))]))
 
 
 ;;--------
@@ -191,88 +199,121 @@
 ;; left and right are Types
 (def-structural Pair ([left #:covariant]
                       [right #:covariant])
-  [#:type-mask mask:pair])
+  [#:mask mask:pair]
+  [#:custom-constructor
+   (if (or (Bottom? left) (Bottom? right))
+       -Bottom
+       (make-Pair left right))])
 
 ;;----------------
 ;; Mutable Pairs
 ;;----------------
 
-(def-type MPairTop () [#:type-mask mask:mpair] #:base)
+(def-type MPairTop ()
+  [#:mask mask:mpair]
+  [#:singleton -MPairTop])
 
 ;; *mutable* pairs - distinct from regular pairs
 ;; left and right are Types
 (def-structural MPair ([left #:invariant] [right #:invariant])
-  [#:type-mask mask:mpair]
-  [#:top MPairTop?])
+  [#:mask mask:mpair]
+  [#:custom-constructor
+   (if (or (Bottom? left) (Bottom? right))
+       -Bottom
+       (make-MPair left right))])
 
 ;;----------
 ;; Vectors
 ;;----------
 
-(def-type VectorTop () [#:type-mask mask:vector] #:base)
+(def-type VectorTop () [#:mask mask:vector]
+  [#:singleton -VectorTop])
 
 ;; elem is a Type
 (def-structural Vector ([elem #:invariant])
-  [#:type-mask mask:vector]
-  [#:top VectorTop?])
+  [#:mask mask:vector])
 
 ;;------
 ;; Box
 ;;------
 
 (def-type BoxTop ()
-  [#:type-mask mask:box] #:base)
+  [#:mask mask:box]
+  [#:singleton -BoxTop])
 
 (def-structural Box ([elem #:invariant])
-  [#:type-mask mask:box]
-  [#:top BoxTop?])
+  [#:mask mask:box]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Box elem))])
 
 ;;----------
 ;; Channel
 ;;----------
 
 (def-type ChannelTop ()
-  [#:type-mask mask:channel] #:base)
+  [#:mask mask:channel]
+  [#:singleton -ChannelTop])
 
 (def-structural Channel ([elem #:invariant])
-  [#:type-mask mask:channel]
-  [#:top ChannelTop?])
+  [#:mask mask:channel]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Channel elem))])
 
 ;;----------------
 ;; Async-Channel
 ;;----------------
 
 (def-type Async-ChannelTop ()
-  [#:type-mask mask:channel] #:base)
+  [#:mask mask:channel]
+  [#:singleton -Async-ChannelTop])
 
 (def-structural Async-Channel ([elem #:invariant])
-  [#:type-mask mask:channel]
-  [#:top Async-ChannelTop?])
+  [#:mask mask:channel]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Async-Channel elem))])
 
 ;;-------------
 ;; ThreadCell
 ;;-------------
 
 (def-type ThreadCellTop ()
-  [#:type-mask mask:thread-cell] #:base)
+  [#:mask mask:thread-cell]
+  [#:singleton -ThreadCellTop])
 
 (def-structural ThreadCell ([elem #:invariant])
-  [#:type-mask mask:thread-cell]
-  [#:top ThreadCellTop?])
+  [#:mask mask:thread-cell]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-ThreadCell elem))])
 
 ;;----------
 ;; Promise
 ;;----------
 
 (def-structural Promise ([elem #:covariant])
-  [#:type-mask mask:promise])
+  [#:mask mask:promise]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Promise elem))])
 
 ;;------------
 ;; Ephemeron
 ;;------------
 
 (def-structural Ephemeron ([elem #:covariant])
-  [#:type-mask mask:ephemeron])
+  [#:mask mask:ephemeron]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Ephemeron elem))])
 
 
 ;;-----------
@@ -280,11 +321,15 @@
 ;;-----------
 
 (def-type Weak-BoxTop ()
-  [#:type-mask mask:other-box] #:base)
+  [#:mask mask:other-box]
+  [#:singleton -Weak-BoxTop])
 
 (def-structural Weak-Box ([elem #:invariant])
-  [#:type-mask mask:other-box]
-  [#:top Weak-BoxTop?])
+  [#:mask mask:other-box]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-Weak-Box elem))])
 
 
 ;;---------------
@@ -292,7 +337,11 @@
 ;;---------------
 
 (def-structural CustodianBox ([elem #:covariant])
-  [#:type-mask mask:other-box])
+  [#:mask mask:other-box]
+  [#:custom-constructor
+   (if (Bottom? elem)
+       -Bottom
+       (make-CustodianBox elem))])
 
 ;;------
 ;; Set
@@ -300,19 +349,19 @@
 
 ;; TODO separate mutable/immutable set types
 (def-structural Set ([elem #:covariant])
-  [#:type-mask mask:set])
+  [#:mask mask:set])
 
 ;;------------
 ;; Hashtable
 ;;------------
 
 (def-type HashtableTop ()
-  [#:type-mask mask:hash] #:base)
+  [#:mask mask:hash]
+  [#:singleton -HashtableTop])
 
 ;; TODO separate mutable/immutable Hashtables
 (def-structural Hashtable ([key #:invariant] [value #:invariant])
-  [#:type-mask mask:hash]
-  [#:top HashtableTop?])
+  [#:mask mask:hash])
 
 
 ;;------
@@ -327,7 +376,7 @@
 
 (def-structural Param ([in #:contravariant]
                        [out #:covariant])
-  [#:type-mask mask:procedure])
+  [#:mask mask:procedure])
 
 
 ;;---------
@@ -336,14 +385,22 @@
 
 ;; t is the type of the result of syntax-e, not the result of syntax->datum
 (def-structural Syntax ([t #:covariant])
-  [#:type-mask mask:syntax])
+  [#:mask mask:syntax]
+  [#:custom-constructor
+   (if (Bottom? t)
+       -Bottom
+       (make-Syntax t))])
 
 ;;---------
 ;; Future
 ;;---------
 
 (def-structural Future ([t #:covariant])
-  [#:type-mask mask:future])
+  [#:mask mask:future]
+  [#:custom-constructor
+   (if (Bottom? t)
+       -Bottom
+       (make-Future t))])
 
 
 ;;---------------
@@ -351,7 +408,8 @@
 ;;---------------
 
 (def-type Prompt-TagTop ()
-  [#:type-mask mask:prompt-tag] #:base)
+  [#:mask mask:prompt-tag]
+  [#:singleton -Prompt-TagTop])
 
 ;; body: the type of the body
 ;; handler: the type of the prompt handler
@@ -359,20 +417,23 @@
 ;;   and the codomains of `handler`
 (def-structural Prompt-Tagof ([body #:invariant]
                               [handler #:invariant])
-  [#:type-mask mask:prompt-tag]
-  [#:top Prompt-TagTop?])
+  [#:mask mask:prompt-tag]
+  [#:custom-constructor
+   (if (or (Bottom? body) (Bottom? handler))
+       -Bottom
+       (make-Prompt-Tagof body handler))])
 
 ;;--------------------------
 ;; Continuation-Mark-Keyof
 ;;--------------------------
 
 (def-type Continuation-Mark-KeyTop ()
-  [#:type-mask mask:continuation-mark-key] #:base)
+  [#:mask mask:continuation-mark-key]
+  [#:singleton -Continuation-Mark-KeyTop])
 
 ;; value: the type of allowable values
 (def-structural Continuation-Mark-Keyof ([value #:invariant])
-  [#:type-mask mask:continuation-mark-key]
-  [#:top Continuation-Mark-KeyTop?])
+  [#:mask mask:continuation-mark-key])
 
 ;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
 ;; List/Vector Types (that are not simple structural types)
@@ -380,7 +441,6 @@
 
 ;; dotted list -- after expansion, becomes normal Pair-based list type
 (def-type ListDots ([dty Type?] [dbound (or/c symbol? natural-number/c)])
-  [#:intern-key (cons (Rep-seq dty) dbound)]
   [#:frees
    [#:vars (f)
     (if (symbol? dbound)
@@ -390,19 +450,21 @@
     (if (symbol? dbound)
         (combine-frees (list (single-free-var dbound) (f dty)))
         (f dty))]]
-  [#:fold (f) (make-ListDots (f dty) dbound)]
-  [#:walk (f) (f dty)])
+  [#:fmap (f) (make-ListDots (f dty) dbound)]
+  [#:for-each (f) (f dty)])
 
 
 
 ;; elems are all Types
 (def-type HeterogeneousVector ([elems (listof Type?)])
-  [#:intern-key (map Rep-seq elems)]
   [#:frees (f) (make-invariant (combine-frees (map f elems)))]
-  [#:fold (f) (make-HeterogeneousVector (map f elems))]
-  [#:walk (f) (for-each f elems)]
-  [#:type-mask mask:vector]
-  [#:top VectorTop?])
+  [#:fmap (f) (make-HeterogeneousVector (map f elems))]
+  [#:for-each (f) (for-each f elems)]
+  [#:mask mask:vector]
+  [#:custom-constructor
+   (if (ormap Bottom? elems)
+       -Bottom
+       (make-HeterogeneousVector elems))])
 
 
 ;; * * * * * * *
@@ -412,34 +474,35 @@
 
 (def-type Mu ([body Type?])
   #:no-provide
-  [#:intern-key (Rep-seq body)]
   [#:frees (f) (f body)]
-  [#:fold (f) (make-Mu (f body))]
-  [#:walk (f) (f body)]
-  [#:type-mask (Type-mask body)]
-  #:needs-resolving)
+  [#:fmap (f) (make-Mu (f body))]
+  [#:for-each (f) (f body)]
+  [#:mask (λ (t) (mask (Mu-body t)))]
+  [#:custom-constructor
+   (cond
+     [(Bottom? body) -Bottom]
+     [(or (Value? body) (Base? body)) body]
+     [else (make-Mu body)])])
 
 ;; n is how many variables are bound here
 ;; body is a type
 (def-type Poly ([n exact-nonnegative-integer?]
                 [body Type?])
   #:no-provide
-  [#:intern-key (cons n (Rep-seq body))]
   [#:frees (f) (f body)]
-  [#:fold (f) (make-Poly n (f body))]
-  [#:walk (f) (f body)]
-  [#:type-mask (Type-mask body)])
+  [#:fmap (f) (make-Poly n (f body))]
+  [#:for-each (f) (f body)]
+  [#:mask (λ (t) (mask (Poly-body t)))])
 
 ;; n is how many variables are bound here
 ;; there are n-1 'normal' vars and 1 ... var
 (def-type PolyDots ([n exact-nonnegative-integer?]
                     [body Type?])
   #:no-provide
-  [#:intern-key (cons n (Rep-seq body))]
   [#:frees (f) (f body)]
-  [#:fold (f) (make-PolyDots n (f body))]
-  [#:walk (f) (f body)]
-  [#:type-mask (Type-mask body)])
+  [#:fmap (f) (make-PolyDots n (f body))]
+  [#:for-each (f) (f body)]
+  [#:mask (λ (t) (mask (PolyDots-body t)))])
 
 ;; interp. A row polymorphic function type
 ;; constraints are row absence constraints, represented
@@ -447,15 +510,16 @@
 (def-type PolyRow ([constraints (list/c list? list? list? list?)]
                    [body Type?])
   #:no-provide
-  [#:intern-key (cons (Rep-seq body) constraints)]
   [#:frees (f) (f body)]
-  [#:fold (f) (make-PolyRow constraints (f body))]
-  [#:walk (f) (f body)]
-  [#:type-mask (Type-mask body)])
+  [#:fmap (f) (make-PolyRow constraints (f body))]
+  [#:for-each (f) (f body)]
+  [#:mask (λ (t) (mask (PolyRow-body t)))])
 
-;; pred : identifier
-(def-type Opaque ([pred identifier?]) #:base
-  [#:intern-key (hash-id pred)])
+
+(def-type Opaque ([pred identifier?])
+  #:base
+  [#:custom-constructor
+   (make-Opaque (normalize-id pred))])
 
 
 
@@ -463,20 +527,16 @@
 ;; ty : Type
 ;; required? : Boolean
 (def-rep Keyword ([kw keyword?] [ty Type?] [required? boolean?])
-  [#:intern-key (vector-immutable kw (Rep-seq ty) required?)]
   [#:frees (f) (f ty)]
-  [#:fold (f) (make-Keyword kw (f ty) required?)]
-  [#:walk (f) (f ty)])
+  [#:fmap (f) (make-Keyword kw (f ty) required?)]
+  [#:for-each (f) (f ty)])
+
 
 (def-rep arr ([dom (listof Type?)]
               [rng SomeValues?]
               [rest (or/c #f Type?)]
               [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))]
               [kws (listof Keyword?)])
-  [#:intern-key (vector-immutable
-                 (map Rep-seq dom) (Rep-seq rng) (and rest (Rep-seq rest))
-                 (and drest (cons (Rep-seq (car drest)) (cdr drest)))
-                 (map Rep-seq kws))]
   [#:frees
    [#:vars (f)
     (combine-frees
@@ -499,18 +559,18 @@
                           dom))
              (match drest
                [(cons t (? symbol? bnd))
-                (list (single-free-var bnd Contravariant)
+                (list (single-free-var bnd variance:contra)
                       (flip-variances (f t)))]
                [(cons t _)
                 (list (flip-variances (f t)))]
                [_ null])
              (list (f rng))))]]
-  [#:fold (f) (make-arr (map f dom)
+  [#:fmap (f) (make-arr (map f dom)
                         (f rng)
                         (and rest (f rest))
                         (and drest (cons (f (car drest)) (cdr drest)))
                         (map f kws))]
-  [#:walk (f)
+  [#:for-each (f)
    (for-each f dom)
    (f rng)
    (when drest (f (car drest)))
@@ -519,81 +579,83 @@
 
 ;; arities : Listof[arr]
 (def-type Function ([arities (listof arr?)])
-  [#:intern-key (map Rep-seq arities)]
-  [#:type-mask mask:procedure]
+  [#:mask mask:procedure]
   [#:frees (f) (combine-frees (map f arities))]
-  [#:fold (f) (make-Function (map f arities))]
-  [#:walk (f) (for-each f arities)])
+  [#:fmap (f) (make-Function (map f arities))]
+  [#:for-each (f) (for-each f arities)])
 
 
 (def-rep fld ([t Type?] [acc identifier?] [mutable? boolean?])
-  [#:intern-key (cons (hash-id acc) (Rep-seq t))]
   [#:frees (f) (if mutable? (make-invariant (f t)) (f t))]
-  [#:fold (f) (make-fld (f t) acc mutable?)]
-  [#:walk (f) (f t)])
+  [#:fmap (f) (make-fld (f t) acc mutable?)]
+  [#:for-each (f) (f t)]
+  [#:custom-constructor
+   (make-fld t (normalize-id acc) mutable?)])
 
-;; name : identifier
-;; parent : Struct
-;; flds : Listof[fld]
-;; proc : Function Type
 ;; poly? : is this type polymorphically variant
 ;;         If not, then the predicate is enough for higher order checks
 ;; pred-id : identifier for the predicate of the struct
-;; acc-ids : names of the accessors
-;; maker-id : name of the constructor
 (def-type Struct ([name identifier?]
                   [parent (or/c #f Struct?)]
                   [flds (listof fld?)]
                   [proc (or/c #f Function?)]
                   [poly? boolean?]
                   [pred-id identifier?])
-  [#:intern-key (cons (hash-id name) (map Rep-seq flds))]
   [#:frees (f) (combine-frees (map f (append (if proc (list proc) null)
                                              (if parent (list parent) null)
                                              flds)))]
-  [#:fold (f) (make-Struct name
+  [#:fmap (f) (make-Struct name
                            (and parent (f parent))
                            (map f flds)
                            (and proc (f proc))
                            poly?
                            pred-id)]
-  [#:walk (f)
-   (f parent)
+  [#:for-each (f)
+   (when parent (f parent))
    (for-each f flds)
-   (f proc)]
+   (when proc (f proc))]
   ;; This should eventually be based on understanding of struct properties.
-  [#:type-mask (mask-union mask:struct mask:procedure)])
+  [#:mask (mask-union mask:struct mask:procedure)]
+  [#:custom-constructor
+   (cond
+     [(ormap (λ (fld) (Bottom? (fld-t fld))) flds) -Bottom]
+     [else (make-Struct (normalize-id name)
+                        parent
+                        flds
+                        proc
+                        poly?
+                        (normalize-id pred-id))])])
 
 ;; Represents prefab structs
 ;; key  : prefab key encoding mutability, auto-fields, etc.
 ;; flds : the types of all of the prefab fields
 (def-type Prefab ([key prefab-key?]
                   [flds (listof Type?)])
-  [#:intern-key (cons key (map Rep-seq flds))]
   [#:frees (f) (combine-frees (map f flds))]
-  [#:fold (f) (make-Prefab key (map f flds))]
-  [#:walk (f) (for-each f flds)]
-  [#:type-mask mask:prefab])
+  [#:fmap (f) (make-Prefab key (map f flds))]
+  [#:for-each (f) (for-each f flds)]
+  [#:mask mask:prefab]
+  [#:custom-constructor
+   (cond
+     [(ormap Bottom? flds) -Bottom]
+     [else (make-Prefab key flds)])])
 
 (def-type StructTypeTop ()
-  #:base
-  [#:type-mask mask:struct-type])
+  [#:mask mask:struct-type]
+  [#:singleton -StructTypeTop])
 
 ;; A structure type descriptor
 (def-type StructType ([s (or/c F? B? Struct? Prefab?)])
-  [#:intern-key (Rep-seq s)]
   [#:frees (f) (f s)]
-  [#:fold (f) (make-StructType (f s))]
-  [#:walk (f) (f s)]
-  [#:type-mask mask:struct-type]
-  [#:top StructTypeTop?])
+  [#:fmap (f) (make-StructType (f s))]
+  [#:for-each (f) (f s)]
+  [#:mask mask:struct-type])
 
 (def-type StructTop ([name Struct?])
-  [#:intern-key (Rep-seq name)]
   [#:frees (f) (f name)]
-  [#:fold (f) (make-StructTop (f name))]
-  [#:walk (f) (f name)]
-  [#:type-mask (mask-union mask:struct mask:procedure)])
+  [#:fmap (f) (make-StructTop (f name))]
+  [#:for-each (f) (f name)]
+  [#:mask (mask-union mask:struct mask:procedure)])
 
 
 
@@ -603,80 +665,117 @@
 ;; base types are redone:
 (def-type Value ([val any/c])
   #:base
-  [#:intern-key val]
-  [#:type-mask
-   (match val
-     [(? number?) mask:number]
-     [#t mask:true]
-     [#f mask:false]
-     [(? symbol?) mask:symbol]
-     [(? string?) mask:string]
-     [(? char?) mask:char]
-     [(? null?) mask:null]
-     [(? void?) mask:void]
-     [_ mask:unknown])])
+  [#:mask (λ (t) (match (Value-val t)
+                   [(? number?) mask:number]
+                   [#t mask:true]
+                   [#f mask:false]
+                   [(? symbol?) mask:symbol]
+                   [(? string?) mask:string]
+                   [(? char?) mask:char]
+                   [(? null?) mask:null]
+                   [(? void?) mask:void]
+                   [_ mask:unknown]))])
 
 ;; elems : Listof[Type]
-(def-type Union ([elems (and/c (listof Type?) (length>=/c 2))])
+(def-type Union ([mask type-mask?]
+                 [elems (and/c (hsetof Type?)
+                               (λ (h) (zero? (hset-count h))))])
   #:no-provide
-  [#:intern-key (for/hash ([elem (in-list elems)]) (values elem #t))]
-  [#:frees (f) (combine-frees (map f elems))]
-  [#:fold (f) (apply Un (map f elems))]
-  [#:walk (f) (for-each f elems)]
-  [#:type-mask
-   (for/fold ([mask mask:bottom])
-             ([elem (in-list elems)])
-     (mask-union mask (Type-mask elem)))])
+  [#:frees (f) (combine-frees (hset-map elems f))]
+  [#:fmap (f) (Union-map elems f)]
+  [#:for-each (f) (hset-for-each elems f)]
+  [#:mask (λ (t) (Union-mask t))])
 
-(define (make-Union* elems)
-  (match elems
-    [(list) (make-Bottom)]
-    [(list t) t]
-    [_ (make-Union elems)]))
+(define-match-expander Union:*
+  (syntax-rules () [(_ elems-pat) (Union: _ elems-pat)]))
+
+(define build-union
+  (let ([union-intern-table (make-weak-hash)])
+    (λ (m ts)
+      (cond
+        [(hset-member? ts Univ) Univ]
+        [else
+         (let ([ts (hset-remove ts -Bottom)])
+           (case (hset-count ts)
+             [(0) -Bottom]
+             [(1) (hset-first ts)]
+             [else (ephemeron-value
+                    (hash-ref! union-intern-table ts
+                               (λ () (let ([t (make-Union m ts)])
+                                       (make-ephemeron ts t)))))]))]))))
+
+;; Union-map
+;;
+;; maps function 'f' over hashet 'args', producing a Union
+;; Note: this is the core constructor for all Unions!
+;; Unions are interned according to their element set,
+;; but in a way which does not leak memory (i.e. Unions which
+;; are no longer referenced outside of the interning machinery
+;; will be garbage collected)
+(define/cond-contract (Union-map args f)
+  (-> (hsetof Type?) procedure? Type?)
+  (define-values (m ts)
+    (for*/fold ([m mask:bottom] [ts (hset)])
+               ([arg (in-hset args)]
+                [arg (in-value (f arg))])
+      (match arg
+        [(Union: m* ts*)
+         (values (mask-union m m*)
+                 (hset-union ts ts*))]
+        [_ (values
+            (mask-union m (mask arg))
+            (hset-add ts arg))])))
+  (build-union m ts))
+
+(define (Un . args)
+  (Union-map (list->hset args) values))
+
+(define (make-Union* args)
+  (Union-map args values))
 
 ;; Intersection
-(def-type Intersection ([elems (and/c (listof Type?) (length>=/c 2))])
-  [#:intern-key (for/hash ([elem (in-list elems)]) (values elem #t))]
-  [#:frees (f) (combine-frees (map f elems))]
-  [#:fold (f) (apply -unsafe-intersect (map f elems))]
-  [#:walk (f) (for-each f elems)]
-  [#:type-mask
-   (for/fold ([mask mask:unknown])
-             ([elem (in-list elems)])
-     (mask-intersect mask (Type-mask elem)))])
+(def-type Intersection ([elems (and/c (hsetof Type?)
+                                      (λ (h) (zero? (hset-count h))))])
+  [#:frees (f) (combine-frees (hset-map elems f))]
+  [#:fmap (f) (apply -unsafe-intersect (hset-map elems f))]
+  [#:for-each (f) (hset-for-each elems f)]
+  [#:mask (λ (t) (for/fold ([m mask:unknown])
+                           ([elem (in-hset (Intersection-elems t))])
+                   (mask-intersect m (mask elem))))])
 
 ;;  constructor for intersections
 ;; in general, intersections should be built
 ;; using the 'intersect' operator, which worries
 ;; about actual subtyping, etc...
 (define (-unsafe-intersect . ts)
-  (let loop ([elems (set)]
+  (let loop ([elems (hset)]
              [ts ts])
     (match ts
       [(list)
        (cond
-         [(set-empty? elems) (make-Univ)]
+         [(hset-empty? elems) Univ]
          ;; size = 1 ?
-         [(= 1 (set-count elems)) (set-first elems)]
+         [(= 1 (hset-count elems)) (hset-first elems)]
          ;; size > 1, build an intersection
-         [else (make-Intersection (set->list elems))])]
+         [else (make-Intersection elems)])]
       [(cons t ts)
        (match t
-         [(? Bottom?) t]
          [(Univ:) (loop elems ts)]
-         [(Intersection: ts*) (loop elems (append ts* ts))]
-         [t (cond
-              [(for/or ([elem (in-immutable-set elems)]) (not (overlap? elem t)))
-               (make-Bottom)]
-              [else (loop (set-add elems t) ts)])])])))
+         [(Intersection: ts*) (loop elems (append (hset->list ts*) ts))]
+         [_ #:when (for/or ([elem (in-hset elems)]) (not (overlap? elem t)))
+            -Bottom]
+         [_ (loop (hset-add elems t) ts)])])))
 
 
 (def-type Refinement ([parent Type?] [pred identifier?])
-  [#:intern-key (cons (hash-id pred) (Rep-seq parent))]
   [#:frees (f) (f parent)]
-  [#:fold (f) (make-Refinement (f parent) pred)]
-  [#:walk (f) (f parent)]
-  [#:type-mask (Type-mask parent)])
+  [#:fmap (f) (make-Refinement (f parent) pred)]
+  [#:for-each (f) (f parent)]
+  [#:mask (λ (t) (mask (Refinement-parent t)))]
+  [#:custom-constructor
+   (if (Bottom? parent)
+       -Bottom
+       (make-Refinement parent (normalize-id pred)))])
 
 ;; A Row used in type instantiation
 ;; For now, this should not appear in user code. It's used
@@ -690,13 +789,6 @@
               [augments (listof (list/c symbol? Type?))]
               [init-rest (or/c Type? #f)])
   #:no-provide
-  [#:intern-key
-   (let ([intern (λ (l) (list-update l 1 Rep-seq))])
-     (list (map intern inits)
-           (map intern fields)
-           (map intern methods)
-           (map intern augments)
-           (and init-rest (Rep-seq init-rest))))]
   [#:frees (f)
    (let ([extract-frees (λ (l) (f (second l)))])
      (combine-frees
@@ -705,14 +797,14 @@
               (map extract-frees methods)
               (map extract-frees augments)
               (if init-rest (list (f init-rest)) null))))]
-  [#:fold (f)
+  [#:fmap (f)
    (let ([update (λ (l) (list-update l 1 f))])
      (make-Row (map update inits)
                (map update fields)
                (map update methods)
                (map update augments)
                (and init-rest (f init-rest))))]
-  [#:walk (f)
+  [#:for-each (f)
    (let ([walk (λ (l) (f (second l)))])
      (for-each walk inits)
      (for-each walk fields)
@@ -721,8 +813,8 @@
      (when init-rest (f init-rest)))])
 
 (def-type ClassTop ()
-  #:base
-  [#:type-mask mask:class])
+  [#:mask mask:class]
+  [#:singleton -ClassTop])
 
 ;; row-ext : Option<(U F B Row)>
 ;; row     : Row
@@ -734,18 +826,16 @@
 (def-type Class ([row-ext (or/c #f F? B? Row?)]
                  [row Row?])
   #:no-provide
-  [#:intern-key (cons (and row-ext (Rep-seq row-ext)) (Rep-seq row))]
   [#:frees (f)
    (combine-frees
     (append (if row-ext (list (f row-ext)) null)
             (list (f row))))]
-  [#:fold (f) (make-Class (and row-ext (f row-ext))
+  [#:fmap (f) (make-Class (and row-ext (f row-ext))
                           (f row))]
-  [#:walk (f)
+  [#:for-each (f)
    (when row-ext (f row-ext))
    (f row)]
-  [#:type-mask mask:class]
-  [#:top ClassTop?])
+  [#:mask mask:class])
 
 
 ;;--------------------------
@@ -756,11 +846,10 @@
 ;; not structural because it has special subtyping,
 ; not just simple structural subtyping
 (def-type Instance ([cls Type?])
-  [#:intern-key (Rep-seq cls)]
   [#:frees (f) (f cls)]
-  [#:fold (f) (make-Instance (f cls))]
-  [#:walk (f) (f cls)]
-  [#:type-mask mask:instance])
+  [#:fmap (f) (make-Instance (f cls))]
+  [#:for-each (f) (f cls)]
+  [#:mask mask:instance])
 
 ;; interp:
 ;; name is the id of the signature
@@ -770,21 +859,26 @@
 (def-rep Signature ([name identifier?]
                     [extends (or/c identifier? #f)]
                     [mapping (listof (cons/c identifier? Type?))])
-  [#:intern-key (hash-id name)]
   [#:frees (f) (combine-frees (map (match-lambda
                                      [(cons _ t) (f t)])
                                    mapping))]
-  [#:fold (f) (make-Signature name extends (map (match-lambda
+  [#:fmap (f) (make-Signature name extends (map (match-lambda
                                                   [(cons id t) (cons id (f t))])
                                                 mapping))]
-  [#:walk (f) (for-each (match-lambda
-                          [(cons _ t) (f t)])
-                        mapping)])
+  [#:for-each (f) (for-each (match-lambda
+                              [(cons _ t) (f t)])
+                            mapping)]
+  [#:custom-constructor
+   (make-Signature (normalize-id name)
+                   (and extends (normalize-id extends))
+                   (for*/list ([p (in-list mapping)]
+                               [(id ty) (in-pair p)])
+                     (cons (normalize-id id) ty)))])
 
 
 (def-type UnitTop ()
-  #:base
-  [#:type-mask mask:unit])
+  [#:mask mask:unit]
+  [#:singleton -UnitTop])
 
 
 ;; interp: imports is the list of imported signatures
@@ -795,31 +889,25 @@
                 [exports (listof Signature?)]
                 [init-depends (listof Signature?)]
                 [result SomeValues?])
-  [#:intern-key (list* (Rep-seq result)
-                       (map Rep-seq imports)
-                       (map Rep-seq exports)
-                       (map Rep-seq init-depends))]
   [#:frees (f) (f result)]
-  [#:fold (f) (make-Unit (map f imports)
+  [#:fmap (f) (make-Unit (map f imports)
                          (map f exports)
                          (map f init-depends)
                          (f result))]
-  [#:walk (f)
+  [#:for-each (f)
    (for-each f imports)
    (for-each f exports)
    (for-each f init-depends)
    (f result)]
-  [#:type-mask mask:unit]
-  [#:top UnitTop?])
+  [#:mask mask:unit])
 
 ;; sequences
 ;; includes lists, vectors, etc
 ;; tys : sequence produces this set of values at each step
 (def-type Sequence ([tys (listof Type?)])
-  [#:intern-key (map Rep-seq tys)]
   [#:frees (f) (combine-frees (map f tys))]
-  [#:fold (f) (make-Sequence (map f tys))]
-  [#:walk (f) (for-each f tys)])
+  [#:fmap (f) (make-Sequence (map f tys))]
+  [#:for-each (f) (for-each f tys)])
 
 ;; Distinction
 ;; comes from define-new-subtype
@@ -828,11 +916,14 @@
 ;; ty: a type for the representation (i.e. each distinction
 ;;     is a subtype of its ty)
 (def-type Distinction ([nm symbol?] [id symbol?] [ty Type?])
-  [#:intern-key (list* nm id (Rep-seq ty))]
   [#:frees (f) (f ty)]
-  [#:fold (f) (make-Distinction nm id (f ty))]
-  [#:walk (f) (f ty)]
-  [#:type-mask (Type-mask ty)])
+  [#:fmap (f) (make-Distinction nm id (f ty))]
+  [#:for-each (f) (f ty)]
+  [#:mask (λ (t) (mask (Distinction-ty t)))]
+  [#:custom-constructor
+   (if (Bottom? ty)
+       -Bottom
+       (make-Distinction nm id ty))])
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -855,23 +946,6 @@
       (match cur
         [(F: name*) #:when abstracting? (f name* make-B lvl cur)]
         [(B: idx) #:when not-abstracting? (f idx (λ (x) x) lvl cur)]
-        [(Union: elems)
-         ;; prevents duplicates, which apparently is needed to avoid
-         ;; infinite loops here...?
-         (define seen (make-hasheq))
-         (define ts
-           (for*/fold ([ts null])
-                      ([elem (in-list elems)]
-                       [elem (in-value (rec elem))]
-                       [seq (in-value (Rep-seq elem))])
-             (cond
-               [(hash-ref seen seq #f) ts]
-               [else (hash-set! seen seq #t)
-                     (cons elem ts)])))
-         (match ts
-           [(list) (make-Bottom)]
-           [(list t) t]
-           [_ (make-Union ts)])]
         [(arr: dom rng rest drest kws)
          (make-arr (map rec dom)
                    (rec rng)
@@ -896,7 +970,7 @@
          (make-PolyDots n (rec/lvl body (+ n lvl)))]
         [(Poly: n body)
          (make-Poly n (rec/lvl body (+ n lvl)))]
-        [_ (Rep-fold rec cur)]))))
+        [_ (Rep-fmap cur rec)]))))
 
 (define/cond-contract (abstract-many names ty)
   (-> (listof symbol?) Type? Type?)
@@ -931,7 +1005,8 @@
           [else default]))
   (type-binder-transform transform ty #f))
 
-(define (abstract name ty)
+(define/cond-contract (abstract name ty)
+  (-> symbol? Type? Type?)
   (abstract-many (list name) ty))
 
 (define (instantiate type sc)
@@ -940,7 +1015,7 @@
 ;; the 'smart' constructor
 (define (Mu* name body)
   (let ([v (make-Mu (abstract name body))])
-    (hash-set! name-table v name)
+    (hash-set! var-name-table v name)
     v))
 
 ;; the 'smart' destructor
@@ -964,7 +1039,7 @@
 (define (Poly* names body #:original-names [orig names])
   (if (null? names) body
       (let ([v (make-Poly (length names) (abstract-many names body))])
-        (hash-set! name-table v orig)
+        (hash-set! var-name-table v orig)
         v)))
 
 ;; the 'smart' destructor
@@ -979,7 +1054,7 @@
 (define (PolyDots* names body)
   (if (null? names) body
       (let ([v (make-PolyDots (length names) (abstract-many names body))])
-        (hash-set! name-table v names)
+        (hash-set! var-name-table v names)
         v)))
 
 ;; the 'smart' destructor
@@ -998,7 +1073,7 @@
 ;;
 (define (PolyRow* names constraints body #:original-names [orig names])
   (let ([v (make-PolyRow constraints (abstract-many names body))])
-    (hash-set! name-table v orig)
+    (hash-set! var-name-table v orig)
     v))
 
 (define (PolyRow-body* names t)
@@ -1037,7 +1112,7 @@
     (syntax-case stx ()
       [(_ np bp)
        #'(? Mu?
-            (app (lambda (t) (let ([sym (hash-ref name-table t (lambda _ (gensym)))])
+            (app (lambda (t) (let ([sym (hash-ref var-name-table t (lambda _ (gensym)))])
                                (list sym (Mu-body* sym t))))
                  (list np bp)))])))
 
@@ -1067,7 +1142,7 @@
        #'(? Poly?
             (app (lambda (t)
                    (let* ([n (Poly-n t)]
-                          [syms (hash-ref name-table t (lambda _ (build-list n (lambda _ (gensym)))))])
+                          [syms (hash-ref var-name-table t (lambda _ (build-list n (lambda _ (gensym)))))])
                      (list syms (Poly-body* syms t))))
                  (list nps bp)))])))
 
@@ -1086,7 +1161,7 @@
        #'(? Poly?
             (app (lambda (t)
                    (let* ([n (Poly-n t)]
-                          [syms (hash-ref name-table t (lambda _ (build-list n (lambda _ (gensym)))))]
+                          [syms (hash-ref var-name-table t (lambda _ (build-list n (lambda _ (gensym)))))]
                           [fresh-syms (map fresh-name syms)])
                      (list syms fresh-syms (Poly-body* fresh-syms t))))
                  (list nps freshp bp)))])))
@@ -1112,7 +1187,7 @@
        #'(? PolyDots?
             (app (lambda (t)
                    (let* ([n (PolyDots-n t)]
-                          [syms (hash-ref name-table t (lambda _ (build-list n (lambda _ (gensym)))))])
+                          [syms (hash-ref var-name-table t (lambda _ (build-list n (lambda _ (gensym)))))])
                      (list syms (PolyDots-body* syms t))))
                  (list nps bp)))])))
 
@@ -1134,7 +1209,7 @@
       [(_ nps constrp bp)
        #'(? PolyRow?
             (app (lambda (t)
-                   (define syms (hash-ref name-table t (λ _ (list (gensym)))))
+                   (define syms (hash-ref var-name-table t (λ _ (list (gensym)))))
                    (list syms
                          (PolyRow-constraints t)
                          (PolyRow-body* syms t)))
@@ -1146,7 +1221,7 @@
       [(_ nps freshp constrp bp)
        #'(? PolyRow?
             (app (lambda (t)
-                   (define syms (hash-ref name-table t (λ _ (list (gensym)))))
+                   (define syms (hash-ref var-name-table t (λ _ (list (gensym)))))
                    (define fresh-syms (list (gensym (car syms))))
                    (list syms fresh-syms
                          (PolyRow-constraints t)
diff --git a/typed-racket-lib/typed-racket/rep/values-rep.rkt b/typed-racket-lib/typed-racket/rep/values-rep.rkt
index 0829046c..d4996e61 100644
--- a/typed-racket-lib/typed-racket/rep/values-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/values-rep.rkt
@@ -21,10 +21,9 @@
 ;;---------
 
 (def-values Values ([results (listof Result?)])
-  [#:intern-key (map Rep-seq results)]
   [#:frees (f) (combine-frees (map f results))]
-  [#:fold (f) (make-Values (map f results))]
-  [#:walk (f) (for-each f results)])
+  [#:fmap (f) (make-Values (map f results))]
+  [#:for-each (f) (for-each f results)])
 
 ;; Anything that can be treated as a _simple_
 ;; Values by sufficient expansion
@@ -42,10 +41,9 @@
 ;; return type of functions
 
 (def-values AnyValues ([p Prop?])
-  [#:intern-key (Rep-seq p)]
   [#:frees (f) (f p)]
-  [#:fold (f) (make-AnyValues (f p))]
-  [#:walk (f) (f p)])
+  [#:fmap (f) (make-AnyValues (f p))]
+  [#:for-each (f) (f p)])
 
 ;;-------------
 ;; ValuesDots
@@ -55,8 +53,16 @@
 (def-values ValuesDots ([results (listof Result?)]
                         [dty Type?]
                         [dbound (or/c symbol? natural-number/c)])
-  [#:intern-key (list* (Rep-seq dty) dbound (map Rep-seq results))]
-  [#:frees (f) (combine-frees (map f results))]
-  [#:fold (f) (make-ValuesDots (map f results) (f dty) dbound)]
-  [#:walk (f) (begin (f dty)
-                     (for-each f results))])
+  [#:frees
+   [#:vars (f)
+    (if (symbol? dbound)
+        (free-vars-remove (combine-frees (map free-vars* (cons dty results))) dbound)
+        (combine-frees (map free-vars* (cons dty results))))]
+   [#:idxs (f)
+    (if (symbol? dbound)
+        (combine-frees (cons (single-free-var dbound) 
+                             (map free-idxs* (cons dty results))))
+        (combine-frees (map free-idxs* (cons dty results))))]]
+  [#:fmap (f) (make-ValuesDots (map f results) (f dty) dbound)]
+  [#:for-each (f) (begin (f dty)
+                         (for-each f results))])
diff --git a/typed-racket-lib/typed-racket/static-contracts/equations.rkt b/typed-racket-lib/typed-racket/static-contracts/equations.rkt
index f5cf37bf..90fbf321 100644
--- a/typed-racket-lib/typed-racket/static-contracts/equations.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/equations.rkt
@@ -47,7 +47,7 @@
   (parameterize ((current-variable-values values))
     (let loop ()
       (define change #f) 
-      (for (((v thunk) (equation-set-equations eqs)))
+      (for ([(v thunk) (in-hash (equation-set-equations eqs))])
         (define new-value (thunk))
         (define old-value (hash-ref values v))
         (unless (equal? new-value old-value)
diff --git a/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt b/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt
index 632ad672..6f315c5a 100644
--- a/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt
@@ -1,7 +1,7 @@
 #lang racket/base
 
-;; Implements a check that to determine if a part of a static contract has two (or more) parametric
-;; contracts as direct descendents.
+;; Implements a check to determine if a part of a static contract has two
+;; (or more) parametric contracts as direct descendents.
 
 (require
   "../utils/utils.rkt"
@@ -34,11 +34,11 @@
     (define seen? #f)
     (match sc
       ;; skip already seen sc
-      [(? (λ (sc) (hash-ref seen (list sc variance) #f)))
+      [_ #:when (hash-ref seen (list sc variance) #f)
        (set! seen? #t)]
       [(or (or/sc: elems ...) (and/sc: elems ...))
        (add-equation! eqs (get-var sc)
-                      (lambda () (for/sum ((e (in-list elems)))
+                      (lambda () (for/sum ([e (in-list elems)])
                                    (variable-ref (get-var e)))))]
       [(or (parametric-var/sc: id) (sealing-var/sc: id))
        (add-equation! eqs (get-var sc) (lambda () 1))]
diff --git a/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/typed-racket-lib/typed-racket/typecheck/check-below.rkt
index a167f35b..a83587e6 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-below.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-below.rkt
@@ -3,7 +3,7 @@
 (require "../utils/utils.rkt"
          racket/match (prefix-in - (contract-req))
          racket/format
-         (types utils union subtype prop-ops abbrev)
+         (types utils subtype prop-ops abbrev)
          (utils tc-utils)
          (rep type-rep object-rep prop-rep)
          (typecheck error-message))
@@ -88,8 +88,8 @@
       [(p p) #t]
       [(p #f) #t]
       [((PropSet: p1+ p1-) (PropSet: p2+ p2-))
-       (and (implies-atomic? p1+ p2+)
-            (implies-atomic? p1- p2-))]
+       (and (implies? p1+ p2+)
+            (implies? p1- p2-))]
       [(_ _) #f]))
   (define (object-better? o1 o2)
     (match* (o1 o2)
@@ -98,13 +98,13 @@
       [(_ _) #f]))
   (define (prop-better? p1 p2)
     (or (not p2)
-        (implies-atomic? p1 p2)))
+        (implies? p1 p2)))
 
   (match* (tr1 expected)
     ;; This case has to be first so that bottom (exceptions, etc.) can be allowed in cases
     ;; where multiple values are expected.
     ;; We can ignore the props and objects in the actual value because they would never be about a value
-    [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
+    [((tc-result1: (? Bottom?)) _)
      (fix-results/bottom expected)]
 
     [((tc-any-results: p1) (tc-any-results: p2))
@@ -205,3 +205,4 @@
     [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*))
      (int-err "dotted types with different bounds/propositions/objects in check-below nyi: ~a ~a" tr1 expected)]
     [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)]))
+
diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index 4eee25f9..66c9e357 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -13,7 +13,7 @@
          "signatures.rkt"
          (private parse-type syntax-properties)
          (env lexical-env tvar-env global-env type-alias-helper mvar-env)
-         (types utils abbrev union subtype resolve generalize)
+         (types utils abbrev subtype resolve generalize)
          (typecheck check-below internal-forms)
          (utils tc-utils mutated-vars)
          (rep object-rep type-rep values-rep)
@@ -885,7 +885,7 @@
        (->acc (list Univ)
               (or (and maybe-type (car maybe-type))
                   Univ)
-              (list (make-FieldPE))
+              (list -field)
               #:var getter-id)
        (-> Univ (or (and maybe-type (car maybe-type)) -Bottom)
            -Void))))
diff --git a/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
index c46f0051..a8de8216 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
@@ -5,7 +5,7 @@
          racket/match
          "signatures.rkt" "tc-metafunctions.rkt"
          "tc-funapp.rkt"
-         (types utils abbrev union resolve subtype match-expanders)
+         (types utils abbrev resolve subtype match-expanders)
          (typecheck check-below)
          (private syntax-properties)
          (utils tc-utils)
diff --git a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
index 9fa2b909..7ec7d14d 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
@@ -71,7 +71,7 @@
          (only-in (base-env base-special-env) make-template-identifier)
          (env lexical-env tvar-env global-env 
               signature-env)
-         (types utils abbrev union subtype resolve generalize signatures)
+         (types utils abbrev subtype resolve generalize signatures)
          (typecheck check-below internal-forms)
          (utils tc-utils)
          (rep type-rep values-rep)
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
index 9251785a..68e05d99 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
@@ -5,7 +5,7 @@
          "utils.rkt"
          syntax/parse syntax/stx racket/match
          (typecheck signatures tc-funapp)
-         (types abbrev prop-ops union utils)
+         (types abbrev prop-ops utils)
          (rep type-rep object-rep)
 
          (for-label racket/base racket/bool))
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
index 38dd850c..35c54013 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
@@ -1,10 +1,11 @@
 #lang racket/unit
 
 (require "../../utils/utils.rkt"
+         (utils hset)
          syntax/parse syntax/stx racket/match racket/sequence
          "signatures.rkt"
          "utils.rkt"
-         (types utils abbrev numeric-tower union resolve type-table generalize)
+         (types utils abbrev numeric-tower resolve type-table generalize)
          (typecheck signatures check-below)
          (rep type-rep type-mask rep-utils)
          (for-label racket/unsafe/ops racket/base))
@@ -127,8 +128,8 @@
       ;; we re-run this whole algorithm with that.  Otherwise, we treat
       ;; it like any other expected type.
       [(tc-result1: (app resolve (Union: ts))) (=> continue)
-       (define u-ts (for/list ([t (in-list ts)]
-                               #:when (eq? mask:vector (Type-mask t)))
+       (define u-ts (for/list ([t (in-hset ts)]
+                               #:when (eq? mask:vector (mask t)))
                       t))
        (match u-ts
          [(list t0) (tc/app #'(#%plain-app . form) (ret t0))]
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
index 89a4969b..8019c182 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
@@ -5,8 +5,8 @@
          "signatures.rkt"
          "utils.rkt"
          syntax/parse syntax/stx racket/match racket/sequence
-         (typecheck signatures tc-funapp)
-         (types abbrev utils union substitute)
+         (typecheck signatures tc-funapp error-message)
+         (types abbrev utils substitute)
          (rep type-rep)
          (env tvar-env)
          (prefix-in i: (infer infer))
@@ -35,13 +35,10 @@
     (match* ((single-value #'arg0) (stx-map single-value #'(arg ...)))
       ;; if the argument is a ListDots
       [((tc-result1: (ListDots: t0 bound0))
-        (list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var))
-                               ;; a devious hack - just generate #f so the test below succeeds
-                               ;; have to explicitly bind `var' since otherwise `var' appears
-                               ;; on only one side of the or
+        (list (tc-result1: (or (and (ListDots: t bound))
                                ;; NOTE: safe to include these, `map' will error if any list is
                                ;; not the same length as all the others
-                               (and (Listof: t var) (app (λ _ #f) bound))))
+                               (and (Listof: t) (bind bound #f ))))
               ...))
        (=> fail)
        (unless (for/and ([b (in-list bound)]) (or (not b) (eq? bound0 b))) (fail))
@@ -81,21 +78,42 @@
         ;; TODO fix double typechecking
         [_ (tc/app-regular #'form expected)])))
   ;; special case for `list'
-  (pattern (list . args)
-    (let ()
-      (define vs (stx-map (λ (x) (gensym)) #'args))
-      (define l-type (-Tuple (map make-F vs)))
-      (define subst
-        (match expected
-          [(tc-result1: t)
-           ;; We want to infer the largest vs that are still under the element types
-           (i:infer vs null (list l-type) (list t) (-values (list (-> l-type Univ))))]
-          [_ #f]))
-      (ret (-Tuple
-             (for/list ([i (in-syntax #'args)] [v (in-list vs)])
-               (or (and subst
-                        (tc-expr/check/t? i (ret (subst-all subst (make-F v)))))
-                   (tc-expr/t i)))))))
+  (pattern
+   (list . args)
+   (let ([args-list (syntax->list #'args)])
+   (match expected
+     [(tc-result1: t)
+      (match t
+        [(List: ts)
+         (cond
+           [(= (length ts) (length args-list))
+            (for ([arg (in-list args-list)]
+                  [t (in-list ts)])
+              (tc-expr/check arg (ret t)))
+            (ret t)]
+           [else
+            (expected-but-got t (-Tuple (map tc-expr/t args-list)))
+            (ret t)])]
+        [_
+         (define vs (map (λ (_) (gensym)) args-list))
+         (define l-type (-Tuple (map make-F vs)))
+         ;; We want to infer the largest vs that are still under the element types
+         (define substs (i:infer vs null (list l-type) (list t) (-values (list (-> l-type Univ)))
+                                 #:multiple? #t))
+         (cond
+           [substs
+            (define result
+              (for*/first ([subst (in-list substs)]
+                           [argtys (in-value (for/list ([arg (in-list args-list)]
+                                                        [v (in-list vs)])
+                                               (tc-expr/check/t? arg (ret (subst-all subst (make-F v))))))]
+                           #:when (andmap values argtys))
+                (ret (-Tuple argtys))))
+            (or result
+                (begin (expected-but-got t (-Tuple (map tc-expr/t args-list)))
+                       expected))]
+           [else (ret (-Tuple (map tc-expr/t args-list)))])])]
+     [_ (ret (-Tuple (map tc-expr/t args-list)))])))
   ;; special case for `list*'
   (pattern (list* (~between args:expr 1 +inf.0) ...)
     (match-let* ([(list tys ... last) (stx-map tc-expr/t #'(args ...))])
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
index aa3bd0ea..17834ede 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
@@ -7,7 +7,7 @@
          racket/format
          racket/list
          (typecheck signatures)
-         (types base-abbrev resolve subtype type-table union utils)
+         (types base-abbrev resolve subtype type-table utils)
          (rep type-rep)
          (utils tc-utils)
 
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt
index 773189db..6f230e74 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt
@@ -6,7 +6,7 @@
          (contract-req)
          (rep type-rep prop-rep object-rep rep-utils)
          (utils tc-utils)
-         (types tc-result resolve subtype update union prop-ops)
+         (types tc-result resolve subtype update prop-ops)
          (env type-env-structs lexical-env mvar-env)
          (rename-in (types abbrev)
                     [-> -->]
@@ -32,7 +32,7 @@
                          (identifier-binding x))
              (let* ([t (lookup-type/lexical x Γ #:fail (lambda _ Univ))]
                     [new-t (update t pt #t lo)])
-               (if (type-equal? new-t -Bottom)
+               (if (Bottom? new-t)
                    (values #f '())
                    (loop ps negs (env-set-type Γ x new-t))))]
             ;; process negative info _after_ positive info so we don't miss anything
@@ -47,7 +47,7 @@
                          [(cons (NotTypeProp: (Path: lo x) pt) rst)
                           (let* ([t (lookup-type/lexical x Γ #:fail (lambda _ Univ))]
                                  [new-t (update t pt #f lo)])
-                            (if (type-equal? new-t -Bottom)
+                            (if (Bottom? new-t)
                                 #f
                                 (loop rst (env-set-type Γ x new-t))))]
                          [_ Γ]))])
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
index ae0fff6e..262575d8 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
@@ -5,7 +5,7 @@
          racket/match (prefix-in - (contract-req))
          "signatures.rkt"
          "check-below.rkt" "../types/kw-types.rkt"
-         (types utils abbrev union subtype type-table path-type
+         (types utils abbrev subtype type-table path-type
                 prop-ops overlap resolve generalize tc-result)
          (private-in syntax-properties parse-type)
          (rep type-rep prop-rep object-rep)
@@ -403,7 +403,7 @@
        [(Box: t) (-box (check-below (find-stx-type x t) t))]
        [_ (-box (generalize (find-stx-type x)))])]
     [(? hash? h)
-     (match (and expected (resolve (intersect expected -HashTop)))
+     (match (and expected (resolve (intersect expected -HashtableTop)))
        [(Hashtable: kt vt)
         (define kts (hash-map h (lambda (x y) (find-stx-type x kt))))
         (define vts (hash-map h (lambda (x y) (find-stx-type y vt))))
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt b/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
index 8159c2b9..255ec3d3 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require (rename-in "../utils/utils.rkt" [infer r:infer])
+         (utils hset)
          racket/match racket/list
          (prefix-in c: (contract-req))
          (env tvar-env)
@@ -160,9 +161,9 @@
       [(? resolvable?)
        (tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)]
       ;; a union of functions can be applied if we can apply all of the elements
-      [(Union: (and ts (list (? Function?) ...)))
+      [(Union: ts) #:when (for/and ([t (in-hset ts)]) (Function? t))
        (merge-tc-results
-        (for/list ([fty ts])
+        (for/list ([fty (in-hset ts)])
           (tc/funapp f-stx args-stx fty args-res expected)))]
       ;; bottom or error type is a perfectly good fcn type
       [(or (Bottom:) (Error:)) (ret f-type)]
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
index a43446df..ffc292cf 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
@@ -6,7 +6,7 @@
          racket/sequence
          (contract-req)
          (rep type-rep object-rep rep-utils)
-         (rename-in (types abbrev utils union)
+         (rename-in (types abbrev utils)
                     [-> t:->]
                     [->* t:->*]
                     [one-of/c t:one-of/c])
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt b/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt
index 30648fbc..c32e7db8 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-literal.rkt
@@ -3,7 +3,7 @@
 (require "../utils/utils.rkt"
          racket/match
          (typecheck signatures check-below)
-         (types abbrev numeric-tower resolve subtype union generalize
+         (types abbrev numeric-tower resolve subtype generalize
                 prefab)
          (rep type-rep)
          (only-in (infer infer) intersect)
@@ -113,7 +113,7 @@
        [_ (make-HeterogeneousVector (for/list ([l (in-vector (syntax-e #'i))])
                                       (generalize (tc-literal l #f))))])]
     [(~var i (3d hash?))
-     (match (and expected (resolve (intersect expected -HashTop)))
+     (match (and expected (resolve (intersect expected -HashtableTop)))
        [(Hashtable: k v)
         (let* ([h (syntax-e #'i)]
                [ks (hash-map h (lambda (x y) (tc-literal x k)))]
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt b/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
index a7d17343..699a6e50 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
@@ -2,7 +2,7 @@
 
 (require "../utils/utils.rkt"
          racket/match racket/list
-         (except-in (types abbrev union utils prop-ops tc-result)
+         (except-in (types abbrev utils prop-ops tc-result)
                     -> ->* one-of/c)
          (rep type-rep prop-rep object-rep values-rep rep-utils)
          (typecheck tc-subst check-below)
@@ -96,8 +96,8 @@
           (loop derived-ors (cons p derived-atoms) worklist)]
 
          [(AndProp: qs) (loop derived-ors derived-atoms (append qs worklist))]
-         [(== -tt prop-equal?) (loop derived-ors derived-atoms worklist)]
-         [(== -ff prop-equal?) (values #f #f)])]
+         [(TrueProp:) (loop derived-ors derived-atoms worklist)]
+         [(FalseProp:) (values #f #f)])]
       [_ (values derived-ors derived-atoms)])))
 
 
@@ -148,8 +148,10 @@
                     (merge-dty dty1 dty2))]
        ;; otherwise, error
        [else
-        (tc-error/expr "Expected the same number of values, but got ~a and ~a"
-                         (length results1) (length results2))])])
+        (tc-error/expr "Expected the same number of values, but got ~a"
+                       (if (< (length results1) (length results2))
+                           (format "~a and ~a." (length results1) (length results2))
+                           (format "~a and ~a." (length results2) (length results1))))])])
 
   (for/fold ([res (ret -Bottom)]) ([res2 (in-list results)])
     (merge-two-results res res2)))
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
index c28544db..f10842e3 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
@@ -9,7 +9,7 @@
          (typecheck signatures tc-funapp tc-metafunctions)
          (types base-abbrev resolve utils type-table)
          (rep type-rep)
-         (utils tc-utils)
+         (utils tc-utils hset)
          (for-template racket/base))
 
 (import tc-expr^)
@@ -41,8 +41,8 @@
          [_ (int-err "non-symbol methods not supported by Typed Racket: ~a"
                      rcvr-type)])]
       ;; union of objects, check pointwise and union the results
-      [(Union: (list (and objs (Instance: _)) ...))
-       (merge-tc-results (map do-check objs))]
+      [(Union: objs) #:when (for/and ([t (in-hset objs)]) (Instance? t))
+       (merge-tc-results (hset-map objs do-check))]
       [_ (tc-error/expr/fields
           "send: type mismatch"
           "expected" "an object"
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
index 9aa2796c..8189bc72 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
@@ -163,15 +163,15 @@
   (define poly-base
     (if (null? tvars)
         name-type
-        (make-App name-type (map make-F tvars) #f)))
+        (make-App name-type (map make-F tvars))))
 
   ;; is this structure covariant in *all* arguments?
   (define (covariant-for? fields mutable)
     (for*/and ([var (in-list tvars)]
                [t (in-list fields)])
-      (let ([variance (hash-ref (free-vars-hash (free-vars* t)) var Constant)])
-        (or (eq? variance Constant)
-            (and (not mutable) (eq? variance Covariant))))))
+      (let ([variance (hash-ref (free-vars-hash (free-vars* t)) var variance:const)])
+        (or (variance:const? variance)
+            (and (not mutable) (variance:co? variance))))))
   (define covariant?
     (and (covariant-for? self-fields mutable)
          (covariant-for? parent-fields parent-mutable)))
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt b/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
index fdf749a8..b367b229 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
@@ -201,4 +201,4 @@
            [else
             (-not-type (make-Path flds nm) (subst not-ty-at-flds))]))]
       ;; else default fold over subfields
-      [_ (Rep-fold subst rep)])))
+      [_ (Rep-fmap rep subst)])))
diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
index 4c4c064d..73d4be6e 100644
--- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
@@ -5,7 +5,7 @@
          racket/list racket/dict racket/match racket/sequence
          (prefix-in c: (contract-req))
          (rep core-rep type-rep values-rep)
-         (types utils abbrev type-table struct-table)
+         (types utils abbrev type-table struct-table resolve)
          (private parse-type type-annotation syntax-properties type-contract)
          (env global-env init-envs type-name-env type-alias-env
               lexical-env env-req mvar-env scoped-tvar-env
@@ -101,7 +101,7 @@
               [mk-ty (match struct-type
                        [(Poly-names: ns body)
                         (make-Poly ns
-                          ((map fld-t (Struct-flds body)) #f . ->* . (make-App t (map make-F ns) #f)))]
+                          ((map fld-t (Struct-flds body)) #f . ->* . (make-App t (map make-F ns))))]
                        [else
                         ((map fld-t (Struct-flds struct-type)) #f . ->* . t)])])
          (register-type #'r.name mk-ty)
@@ -400,12 +400,16 @@
           [else (int-err "Two conflicting definitions: ~a ~a" def other-def)]))
       (dict-update h (binding-name def) merge-def-bindings #f)))
   (do-time "computed def-tbl")
+  ;; check that all parsed apps are sensible
+  (check-registered-apps!)
   ;; typecheck the expressions and the rhss of defintions
   ;(displayln "Starting pass2")
   (for-each tc-toplevel/pass2 forms)
   (do-time "Finished pass2")
   ;; check that declarations correspond to definitions
+  ;; and that any additional parsed apps are sensible
   (check-all-registered-types)
+  (check-registered-apps!)
   ;; log messages to check-syntax to show extra types / arrows before failures
   (log-message online-check-syntax-logger
                'info
diff --git a/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt b/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt
index 710ea3ac..9d8842cb 100644
--- a/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt
@@ -135,7 +135,7 @@
            ;; has no meaningful type to print
            ['no-type #f]
            ;; don't print results of type void
-           [(tc-result1: (== -Void type-equal?)) #f]
+           [(tc-result1: (== -Void)) #f]
            ;; don't print results of unknown type
            [(tc-any-results: f) #f]
            [(tc-result1: t f o)
diff --git a/typed-racket-lib/typed-racket/types/abbrev.rkt b/typed-racket-lib/typed-racket/types/abbrev.rkt
index d26e0752..9c3d0ec7 100644
--- a/typed-racket-lib/typed-racket/types/abbrev.rkt
+++ b/typed-racket-lib/typed-racket/types/abbrev.rkt
@@ -12,12 +12,18 @@
          racket/function
 
          (prefix-in c: (contract-req))
-         (rename-in (rep type-rep prop-rep object-rep values-rep)
+         (rename-in (rep rep-utils type-rep prop-rep object-rep values-rep)
                     [make-Base make-Base*])
-         (types union numeric-tower prefab)
+         (types numeric-tower prefab)
          ;; Using this form so all-from-out works
          "base-abbrev.rkt" "match-expanders.rkt"
 
+         ;; signature env req here is so it is statically required by
+         ;; the code loaded during typechecking, otherwise we get
+         ;; a `reference to a module that is not available` error
+         ;; from references generated by init-envs
+         (env signature-env)
+
          (for-syntax racket/base syntax/parse)
 
          ;; for base type contracts and predicates
@@ -44,7 +50,7 @@
          (only-in '#%place place? place-channel?))
 
 (provide (except-out (all-defined-out) make-Base)
-         (all-from-out "base-abbrev.rkt" "match-expanders.rkt"))
+         (except-out (all-from-out "base-abbrev.rkt" "match-expanders.rkt") make-arr))
 
 ;; All the types defined here are not numeric
 (define (make-Base name contract predicate)
@@ -189,19 +195,6 @@
 (define Syntax-Sexp (-Sexpof Any-Syntax))
 (define Ident (-Syntax -Symbol))
 (define -HT make-Hashtable)
-(define/decl -StructTypeTop (make-StructTypeTop))
-(define/decl -BoxTop (make-BoxTop))
-(define/decl -Weak-BoxTop (make-Weak-BoxTop))
-(define/decl -ChannelTop (make-ChannelTop))
-(define/decl -Async-ChannelTop (make-Async-ChannelTop))
-(define/decl -HashTop (make-HashtableTop))
-(define/decl -VectorTop (make-VectorTop))
-(define/decl -MPairTop (make-MPairTop))
-(define/decl -Thread-CellTop (make-ThreadCellTop))
-(define/decl -Prompt-TagTop (make-Prompt-TagTop))
-(define/decl -Continuation-Mark-KeyTop (make-Continuation-Mark-KeyTop))
-(define/decl -ClassTop (make-ClassTop))
-(define/decl -UnitTop (make-UnitTop))
 (define/decl -Port (Un -Output-Port -Input-Port))
 (define/decl -SomeSystemPath (Un -Path -OtherSystemPath))
 (define/decl -Pathlike (Un -String -Path))
@@ -252,13 +245,6 @@
 (define/decl -Environment-Variables
   (make-Base 'Environment-Variables #'environment-variables? environment-variables?))
 
-;; Paths
-(define/decl -car (make-CarPE))
-(define/decl -cdr (make-CdrPE))
-(define/decl -syntax-e (make-SyntaxPE))
-(define/decl -force (make-ForcePE))
-(define/decl -field (make-FieldPE))
-
 ;; Type alias names
 (define (-struct-name name)
   (make-Name name 0 #t))
diff --git a/typed-racket-lib/typed-racket/types/base-abbrev.rkt b/typed-racket-lib/typed-racket/types/base-abbrev.rkt
index b1461d16..c1cc701c 100644
--- a/typed-racket-lib/typed-racket/types/base-abbrev.rkt
+++ b/typed-racket-lib/typed-racket/types/base-abbrev.rkt
@@ -6,7 +6,8 @@
 ;; extends it with more types and type abbreviations.
 
 (require "../utils/utils.rkt"
-         (rep type-rep prop-rep object-rep values-rep rep-utils)
+         "../rep/type-rep.rkt"
+         (rep prop-rep object-rep values-rep rep-utils)
          (env mvar-env)
          racket/match racket/list (prefix-in c: (contract-req))
          (for-syntax racket/base syntax/parse racket/list)
@@ -17,40 +18,21 @@
          -is-type
          -not-type
          -id-path
+         (all-from-out "../rep/type-rep.rkt")
          (rename-out [make-Listof -lst]
                      [make-MListof -mlst]))
 
-;; This table maps types (or really, the sequence number of the type)
-;; to identifiers that are those types. This allows us to avoid
-;; reconstructing the type when using it from its marshaled
-;; representation.  The table is referenced in env/init-env.rkt
-;;
-;; For example, instead of marshalling a big union for `Integer`, we
-;; simply emit `-Integer`, which evaluates to the right type.
-(define predefined-type-table (make-hasheq))
-(define-syntax-rule (declare-predefined-type! id)
-  (hash-set! predefined-type-table (Rep-seq id) #'id))
-(provide predefined-type-table)
-(define-syntax-rule (define/decl id e)
-  (begin (define id e)
-	 (declare-predefined-type! id)))
-
-;; Top and error types
-(define/decl Univ (make-Univ))
-(define/decl -Bottom (make-Bottom))
-(define/decl Err (make-Error))
-
 (define/decl -False (make-Value #f))
 (define/decl -True (make-Value #t))
-(define/decl -Boolean (make-Union (list -False -True)))
+(define/decl -Boolean (Un -False -True))
 
 (define -val make-Value)
+(define/decl -Null (-val null))
 
 ;; Char type and List type (needed because of how sequences are checked in subtype)
 (define/decl -Char (make-Base 'Char #'char? char? #f))
-(define/decl -Null (-val null))
-(define (make-Listof elem) (-mu list-rec (simple-Un -Null (make-Pair elem list-rec))))
-(define (make-MListof elem) (-mu list-rec (simple-Un -Null (make-MPair elem list-rec))))
+(define (make-Listof elem) (-mu list-rec (Un -Null (make-Pair elem list-rec))))
+(define (make-MListof elem) (-mu list-rec (Un -Null (make-MPair elem list-rec))))
 
 ;; Needed for evt checking in subtype.rkt
 (define/decl -Symbol (make-Base 'Symbol #'symbol? symbol? #f))
@@ -68,21 +50,6 @@
 (define (-Tuple* l b)
   (foldr -pair b l))
 
-;; Simple union type constructor, does not check for overlaps
-;; Normalizes representation by sorting types.
-;; Type * -> Type
-;; The input types can be union types, but should not have a complicated
-;; overlap relationship.
-(define simple-Un
-  (let ([flat (match-lambda
-                [(Union: es) es]
-                [t (list t)])])
-    (case-lambda
-      [() -Bottom]
-      [(t) t]
-      [args
-       (make-Union (remove-duplicates (append-map flat args) type-equal?))])))
-
 ;; Recursive types
 (define-syntax -v
   (syntax-rules ()
@@ -104,11 +71,8 @@
      (make-Result t pset o)]))
 
 ;; Propositions
-(define/decl -tt (make-TrueProp))
-(define/decl -ff (make-FalseProp))
 (define/decl -tt-propset (make-PropSet -tt -tt))
 (define/decl -ff-propset (make-PropSet -ff -ff))
-(define/decl -empty-obj (make-Empty))
 
 (define (-arg-path arg [depth 0])
   (make-Path null (cons depth arg)))
diff --git a/typed-racket-lib/typed-racket/types/classes.rkt b/typed-racket-lib/typed-racket/types/classes.rkt
index b41ab192..417a8039 100644
--- a/typed-racket-lib/typed-racket/types/classes.rkt
+++ b/typed-racket-lib/typed-racket/types/classes.rkt
@@ -140,7 +140,7 @@
                    (append (dict-keys fields) field-cs)
                    (append (dict-keys methods) method-cs)
                    (append (dict-keys augments) augment-cs)))]
-      [_ (Rep-walk infer! cur)]))
+      [_ (Rep-for-each cur infer!)]))
   (map remove-duplicates constraints))
 
 ;; infer-row : RowConstraints Type -> Row
diff --git a/typed-racket-lib/typed-racket/types/current-seen.rkt b/typed-racket-lib/typed-racket/types/current-seen.rkt
index cad1bf99..7ae3e321 100644
--- a/typed-racket-lib/typed-racket/types/current-seen.rkt
+++ b/typed-racket-lib/typed-racket/types/current-seen.rkt
@@ -31,8 +31,6 @@
   (append t1s/t2s A))
 
 (define-syntax-rule (seen? t1 t2 seen-ts)
-  (let ([seq1 (Rep-seq t1)]
-        [seq2 (Rep-seq t2)])
-    (for/or ([p (in-list seen-ts)])
-      (and (= (Rep-seq (car p)) seq1)
-           (= (Rep-seq (cdr p)) seq2)))))
+  (for/or ([p (in-list seen-ts)])
+    (and (equal? (car p) t1)
+         (equal? (cdr p) t2))))
diff --git a/typed-racket-lib/typed-racket/types/generalize.rkt b/typed-racket-lib/typed-racket/types/generalize.rkt
index ad675fa2..96ad346c 100644
--- a/typed-racket-lib/typed-racket/types/generalize.rkt
+++ b/typed-racket-lib/typed-racket/types/generalize.rkt
@@ -2,7 +2,7 @@
 
 (require "../utils/utils.rkt"
          (rep type-rep)
-         "abbrev.rkt" "subtype.rkt" "substitute.rkt" "union.rkt"
+         "abbrev.rkt" "subtype.rkt" "substitute.rkt"
          "numeric-tower.rkt"
          racket/match)
 
diff --git a/typed-racket-lib/typed-racket/types/kw-types.rkt b/typed-racket-lib/typed-racket/types/kw-types.rkt
index 745d47f4..e6760643 100644
--- a/typed-racket-lib/typed-racket/types/kw-types.rkt
+++ b/typed-racket-lib/typed-racket/types/kw-types.rkt
@@ -89,29 +89,26 @@
 (define (prefix-of a b)
   (define (rest-equal? a b)
     (match* (a b)
-      [(#f #f) #t]
+      [(a a) #t]
       [(#f _) #f]
       [(_ #f) #f]
-      [(a b) (type-equal? a b)]))
+      [(_ _) #f]))
   (define (drest-equal? a b)
     (match* (a b)
-      [((list t b) (list t* b*)) (and (type-equal? t t*) (equal? b b*))]
+      [((list t b) (list t b)) #t]
       [(#f #f) #t]
       [(_ _) #f]))
-  (define (kw-equal? a b)
-    (and (equal? (length a) (length b))
-         (for/and ([k1 (in-list a)] [k2 (in-list b)])
-           (type-equal? k1 k2))))
   (match* (a b)
     [((arr: args result rest drest kws)
       (arr: args* result* rest* drest* kws*))
      (and (< (length args) (length args*))
           (rest-equal? rest rest*)
           (drest-equal? drest drest*)
-          (type-equal? result result*)
-          (kw-equal? kws kws*)
-          (for/and ([p (in-list args)] [p* (in-list args*)])
-            (type-equal? p p*)))]))
+          (equal? result result*)
+          (equal? kws kws*)
+          (for/and ([p (in-list args)]
+                    [p* (in-list args*)])
+            (equal? p p*)))]))
 
 (define (arity-length a)
   (match a
diff --git a/typed-racket-lib/typed-racket/types/match-expanders.rkt b/typed-racket-lib/typed-racket/types/match-expanders.rkt
index aba92208..8ec49c3a 100644
--- a/typed-racket-lib/typed-racket/types/match-expanders.rkt
+++ b/typed-racket-lib/typed-racket/types/match-expanders.rkt
@@ -1,26 +1,62 @@
 #lang racket/base
 
-
-(require "../utils/utils.rkt")
-
-(require (rep type-rep values-rep rep-utils)
+(require "../utils/utils.rkt"
+         (utils hset)
+         (rep type-rep values-rep rep-utils)
          racket/match
-         (types resolve)
-         (contract-req)
-         racket/set
+         syntax/parse/define
+         (types resolve base-abbrev)
          (for-syntax racket/base syntax/parse))
 
 (provide Listof: List: MListof: AnyPoly: AnyPoly-names: Function/arrs:
+         SimpleListof: SimpleMListof:
          PredicateProp:)
 
 
 (define-match-expander Listof:
   (lambda (stx)
     (syntax-parse stx
-      [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var])))
+      [(_ elem-pat)
        (syntax/loc stx
-         (or (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat)))))
-             (Mu: var-pat (Union: (list (Pair: elem-pat (F: var-pat)) (Value: '()))))))])))
+         (app Listof? (? Type? elem-pat)))])))
+
+(define-match-expander SimpleListof:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ elem-pat)
+       (syntax/loc stx
+         (app (λ (t) (Listof? t #t)) (? Type? elem-pat)))])))
+
+
+(define-simple-macro (make-Listof-pred listof-pred?:id pair-matcher:id)
+  (define (listof-pred? t [simple? #f])
+    (match t
+      [(Mu-unsafe: (Union: elems))
+       #:when (and (= 2 (hset-count elems))
+                   (hset-member? elems -Null))
+       (match (hset-first (hset-remove elems -Null))
+         [(pair-matcher elem-t (B: 0))
+          (define elem-t* (instantiate-raw-type t elem-t))
+          (cond
+            [simple? (and (equal? elem-t elem-t*) elem-t)]
+            [else elem-t*])]
+         [_ #f])]
+      [(Union: elems)
+       #:when (and (= 2 (hset-count elems))
+                   (hset-member? elems -Null))
+       (match (hset-first (hset-remove elems -Null))
+         [(pair-matcher hd-t tl-t)
+          (cond
+            [(listof-pred? tl-t)
+             => (λ (lst-t) (and (equal? hd-t lst-t) hd-t))]
+            [else #f])]
+         [_ #f])]
+      [_ #f])))
+
+(make-Listof-pred Listof? Pair:)
+(make-Listof-pred MListof? MPair:)
+
+
 
 (define-match-expander List:
   (lambda (stx)
@@ -30,27 +66,33 @@
       [(_ elem-pats #:tail tail-pat)
        #'(? Type? (app untuple (? values elem-pats) tail-pat))])))
 
+(define-match-expander MListof:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ elem-pat)
+       (syntax/loc stx (app MListof? (? Type? elem-pat)))])))
+
+(define-match-expander SimpleMListof:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ elem-pat)
+       (syntax/loc stx (app (λ (t) (MListof? t #t)) (? Type? elem-pat)))])))
+
+
 ;; Type? -> (or/c (values/c #f #f) (values/c (listof Type?) Type?)))
 ;; Returns the prefix of types that are consed on to the last type (a non finite-pair type).
 ;; The last type may contain pairs if it is a list type.
 (define (untuple t)
-  (let loop ((t t) (seen (set)))
-    (if (not (set-member? seen (Rep-seq t)))
+  (let loop ([t t]
+             [seen (hset)])
+    (if (not (hset-member? seen t))
         (match (resolve t)
           [(Pair: a b)
-           (define-values (elems tail) (loop b (set-add seen (Rep-seq t))))
+           (define-values (elems tail) (loop b (hset-add seen t)))
            (values (cons a elems) tail)]
           [_ (values null t)])
         (values null t))))
 
-(define-match-expander MListof:
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var])))
-       ;; see note above
-       #'(or (Mu: var-pat (Union: (list (Value: '()) (MPair: elem-pat (F: var-pat)))))
-             (Mu: var-pat (Union: (list (MPair: elem-pat (F: var-pat)) (Value: '())))))])))
-
 (define (unpoly t)
   (match t
     [(Poly: fixed-vars t)
diff --git a/typed-racket-lib/typed-racket/types/numeric-tower.rkt b/typed-racket-lib/typed-racket/types/numeric-tower.rkt
index e1e481ed..67ac7a95 100644
--- a/typed-racket-lib/typed-racket/types/numeric-tower.rkt
+++ b/typed-racket-lib/typed-racket/types/numeric-tower.rkt
@@ -1,8 +1,8 @@
 #lang racket/base
 
 (require "../utils/utils.rkt"
-         (rename-in (types numeric-predicates base-abbrev)
-                    [simple-Un *Un])
+         (rep rep-utils)
+         (types numeric-predicates base-abbrev)
          (rename-in (rep type-rep) [make-Base make-Base*])
          racket/function
          racket/extflonum
@@ -59,15 +59,15 @@
 (define/decl -One  (make-Value 1))
 
 ;; Infinities (These are part of Flonum/Single-Flonum, but useful abbreviatios.)
-(define/decl -PosInfinity (*Un (-val +inf.0) (-val +inf.f)))
-(define/decl -NegInfinity (*Un (-val -inf.0) (-val -inf.f)))
+(define/decl -PosInfinity (Un (-val +inf.0) (-val +inf.f)))
+(define/decl -NegInfinity (Un (-val -inf.0) (-val -inf.f)))
 
 ;; Integers
 (define/decl -Byte>1 (make-Base 'Byte-Larger-Than-One ; unsigned
 				#'(and/c byte? (lambda (x) (> x 1)))
 				(conjoin byte? (lambda (x) (> x 1)))))
-(define/decl -PosByte (*Un -One -Byte>1))
-(define/decl -Byte    (*Un -Zero -PosByte))
+(define/decl -PosByte (Un -One -Byte>1))
+(define/decl -Byte    (Un -Zero -PosByte))
 (define/decl -PosIndexNotByte
   (make-Base 'Positive-Index-Not-Byte
              ;; index? will be checked at runtime, can be platform-specific
@@ -76,23 +76,23 @@
              (lambda (x) (and (portable-index? x)
                               (positive? x)
                               (not (byte? x))))))
-(define/decl -PosIndex    (*Un -One -Byte>1 -PosIndexNotByte))
-(define/decl -Index       (*Un -Zero -PosIndex))
+(define/decl -PosIndex    (Un -One -Byte>1 -PosIndexNotByte))
+(define/decl -Index       (Un -Zero -PosIndex))
 (define/decl -PosFixnumNotIndex
   (make-Base 'Positive-Fixnum-Not-Index
              #'(and/c fixnum? positive? (not/c index?))
              (lambda (x) (and (portable-fixnum? x)
                               (positive? x)
                               (not (portable-index? x))))))
-(define/decl -PosFixnum    (*Un -PosFixnumNotIndex -PosIndex))
-(define/decl -NonNegFixnum (*Un -PosFixnum -Zero))
+(define/decl -PosFixnum    (Un -PosFixnumNotIndex -PosIndex))
+(define/decl -NonNegFixnum (Un -PosFixnum -Zero))
 (define/decl -NegFixnum
   (make-Base 'Negative-Fixnum
              #'(and/c fixnum? negative?)
              (lambda (x) (and (portable-fixnum? x)
                               (negative? x)))))
-(define/decl -NonPosFixnum (*Un -NegFixnum -Zero))
-(define/decl -Fixnum       (*Un -NegFixnum -Zero -PosFixnum))
+(define/decl -NonPosFixnum (Un -NegFixnum -Zero))
+(define/decl -Fixnum       (Un -NegFixnum -Zero -PosFixnum))
 ;; This type, and others like it, should *not* be exported, or used for
 ;; anything but building unions. Especially, no literals should be given
 ;; these types.
@@ -102,8 +102,8 @@
              (lambda (x) (and (exact-integer? x)
                               (positive? x)
                               (not (portable-fixnum? x))))))
-(define/decl -PosInt    (*Un -PosIntNotFixnum -PosFixnum))
-(define/decl -NonNegInt (*Un -PosInt -Zero))
+(define/decl -PosInt    (Un -PosIntNotFixnum -PosFixnum))
+(define/decl -NonNegInt (Un -PosInt -Zero))
 (define/decl -Nat       -NonNegInt)
 (define/decl -NegIntNotFixnum
   (make-Base 'Negative-Integer-Not-Fixnum
@@ -111,9 +111,9 @@
              (lambda (x) (and (exact-integer? x)
                               (negative? x)
                               (not (portable-fixnum? x))))))
-(define/decl -NegInt    (*Un -NegIntNotFixnum -NegFixnum))
-(define/decl -NonPosInt (*Un -NegInt -Zero))
-(define/decl -Int       (*Un -NegInt -Zero -PosInt))
+(define/decl -NegInt    (Un -NegIntNotFixnum -NegFixnum))
+(define/decl -NonPosInt (Un -NegInt -Zero))
+(define/decl -Int       (Un -NegInt -Zero -PosInt))
 
 ;; Rationals
 (define/decl -PosRatNotInt
@@ -122,17 +122,17 @@
              (lambda (x) (and (exact-rational? x)
                               (positive? x)
                               (not (exact-integer? x))))))
-(define/decl -PosRat    (*Un -PosRatNotInt -PosInt))
-(define/decl -NonNegRat (*Un -PosRat -Zero))
+(define/decl -PosRat    (Un -PosRatNotInt -PosInt))
+(define/decl -NonNegRat (Un -PosRat -Zero))
 (define/decl -NegRatNotInt
   (make-Base 'Negative-Rational-Not-Integer
              #'(and/c exact-rational? negative? (not/c integer?))
              (lambda (x) (and (exact-rational? x)
                               (negative? x)
                               (not (exact-integer? x))))))
-(define/decl -NegRat    (*Un -NegRatNotInt -NegInt))
-(define/decl -NonPosRat (*Un -NegRat -Zero))
-(define/decl -Rat       (*Un -NegRat -Zero -PosRat))
+(define/decl -NegRat    (Un -NegRatNotInt -NegInt))
+(define/decl -NonPosRat (Un -NegRat -Zero))
+(define/decl -Rat       (Un -NegRat -Zero -PosRat))
 
 ;; Floating-point numbers
 ;; NaN is included in all floating-point types
@@ -148,20 +148,20 @@
   (make-Base 'Float-Negative-Zero
 	     #'(lambda (x) (eqv? x -0.0))
 	     (lambda (x) (eqv? x -0.0))))
-(define/decl -FlonumZero (*Un -FlonumPosZero -FlonumNegZero -FlonumNan))
+(define/decl -FlonumZero (Un -FlonumPosZero -FlonumNegZero -FlonumNan))
 (define/decl -PosFlonumNoNan
   (make-Base 'Positive-Float-No-NaN
              #'(and/c flonum? positive?)
              (lambda (x) (and (flonum? x) (positive? x)))))
-(define/decl -PosFlonum (*Un -PosFlonumNoNan -FlonumNan))
-(define/decl -NonNegFlonum (*Un -PosFlonum -FlonumZero))
+(define/decl -PosFlonum (Un -PosFlonumNoNan -FlonumNan))
+(define/decl -NonNegFlonum (Un -PosFlonum -FlonumZero))
 (define/decl -NegFlonumNoNan
   (make-Base 'Negative-Float-No-NaN
              #'(and/c flonum? negative?)
              (lambda (x) (and (flonum? x) (negative? x)))))
-(define/decl -NegFlonum (*Un -NegFlonumNoNan -FlonumNan))
-(define/decl -NonPosFlonum (*Un -NegFlonum -FlonumZero))
-(define/decl -Flonum (*Un -NegFlonumNoNan -FlonumNegZero -FlonumPosZero -PosFlonumNoNan -FlonumNan)) ; 64-bit floats
+(define/decl -NegFlonum (Un -NegFlonumNoNan -FlonumNan))
+(define/decl -NonPosFlonum (Un -NegFlonum -FlonumZero))
+(define/decl -Flonum (Un -NegFlonumNoNan -FlonumNegZero -FlonumPosZero -PosFlonumNoNan -FlonumNan)) ; 64-bit floats
 ;; inexact reals can be flonums (64-bit floats) or 32-bit floats
 (define/decl -SingleFlonumNan
   (make-Base 'Single-Flonum-Nan
@@ -176,40 +176,40 @@
   (make-Base 'Single-Flonum-Negative-Zero
              #'(lambda (x) (eqv? x -0.0f0))
              (lambda (x) (eqv? x -0.0f0))))
-(define/decl -SingleFlonumZero (*Un -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumNan))
-(define/decl -InexactRealNan     (*Un -FlonumNan -SingleFlonumNan))
-(define/decl -InexactRealPosZero (*Un -SingleFlonumPosZero -FlonumPosZero))
-(define/decl -InexactRealNegZero (*Un -SingleFlonumNegZero -FlonumNegZero))
-(define/decl -InexactRealZero    (*Un -InexactRealPosZero
+(define/decl -SingleFlonumZero (Un -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumNan))
+(define/decl -InexactRealNan     (Un -FlonumNan -SingleFlonumNan))
+(define/decl -InexactRealPosZero (Un -SingleFlonumPosZero -FlonumPosZero))
+(define/decl -InexactRealNegZero (Un -SingleFlonumNegZero -FlonumNegZero))
+(define/decl -InexactRealZero    (Un -InexactRealPosZero
                                  -InexactRealNegZero
                                  -InexactRealNan))
 (define/decl -PosSingleFlonumNoNan
   (make-Base 'Positive-Single-Flonum-No-Nan
              #'(and/c single-flonum? positive?)
              (lambda (x) (and (single-flonum? x) (positive? x)))))
-(define/decl -PosSingleFlonum    (*Un -PosSingleFlonumNoNan -SingleFlonumNan))
-(define/decl -PosInexactReal     (*Un -PosSingleFlonum -PosFlonum))
-(define/decl -NonNegSingleFlonum (*Un -PosSingleFlonum -SingleFlonumZero))
-(define/decl -NonNegInexactReal  (*Un -PosInexactReal -InexactRealZero))
+(define/decl -PosSingleFlonum    (Un -PosSingleFlonumNoNan -SingleFlonumNan))
+(define/decl -PosInexactReal     (Un -PosSingleFlonum -PosFlonum))
+(define/decl -NonNegSingleFlonum (Un -PosSingleFlonum -SingleFlonumZero))
+(define/decl -NonNegInexactReal  (Un -PosInexactReal -InexactRealZero))
 (define/decl -NegSingleFlonumNoNan
   (make-Base 'Negative-Single-Flonum-No-Nan
              #'(and/c single-flonum? negative?)
              (lambda (x) (and (single-flonum? x) (negative? x)))))
-(define/decl -NegSingleFlonum    (*Un -NegSingleFlonumNoNan -SingleFlonumNan))
-(define/decl -NegInexactReal     (*Un -NegSingleFlonum -NegFlonum))
-(define/decl -NonPosSingleFlonum (*Un -NegSingleFlonum -SingleFlonumZero))
-(define/decl -NonPosInexactReal  (*Un -NegInexactReal -InexactRealZero))
-(define/decl -SingleFlonum       (*Un -NegSingleFlonum -SingleFlonumNegZero -SingleFlonumPosZero -PosSingleFlonum -SingleFlonumNan))
-(define/decl -InexactReal        (*Un -SingleFlonum -Flonum))
+(define/decl -NegSingleFlonum    (Un -NegSingleFlonumNoNan -SingleFlonumNan))
+(define/decl -NegInexactReal     (Un -NegSingleFlonum -NegFlonum))
+(define/decl -NonPosSingleFlonum (Un -NegSingleFlonum -SingleFlonumZero))
+(define/decl -NonPosInexactReal  (Un -NegInexactReal -InexactRealZero))
+(define/decl -SingleFlonum       (Un -NegSingleFlonum -SingleFlonumNegZero -SingleFlonumPosZero -PosSingleFlonum -SingleFlonumNan))
+(define/decl -InexactReal        (Un -SingleFlonum -Flonum))
 
 ;; Reals
-(define/decl -RealZero      (*Un -Zero -InexactRealZero))
-(define/decl -RealZeroNoNan (*Un -Zero -InexactRealPosZero -InexactRealNegZero))
-(define/decl -PosReal       (*Un -PosRat -PosInexactReal))
-(define/decl -NonNegReal    (*Un -NonNegRat -NonNegInexactReal))
-(define/decl -NegReal       (*Un -NegRat -NegInexactReal))
-(define/decl -NonPosReal    (*Un -NonPosRat -NonPosInexactReal))
-(define/decl -Real          (*Un -Rat -InexactReal))
+(define/decl -RealZero      (Un -Zero -InexactRealZero))
+(define/decl -RealZeroNoNan (Un -Zero -InexactRealPosZero -InexactRealNegZero))
+(define/decl -PosReal       (Un -PosRat -PosInexactReal))
+(define/decl -NonNegReal    (Un -NonNegRat -NonNegInexactReal))
+(define/decl -NegReal       (Un -NegRat -NegInexactReal))
+(define/decl -NonPosReal    (Un -NonPosRat -NonPosInexactReal))
+(define/decl -Real          (Un -Rat -InexactReal))
 
 ;; Complexes
 ;; We could go into _much_ more precision here.
@@ -290,11 +290,11 @@
 	       (and (number? x)
 		    (single-flonum? (imag-part x))
 		    (single-flonum? (real-part x))))))
-(define/decl -ExactNumber (*Un -ExactImaginary -ExactComplex -Rat))
-(define/decl -InexactImaginary (*Un -FloatImaginary -SingleFlonumImaginary))
-(define/decl -Imaginary (*Un -ExactImaginary -InexactImaginary))
-(define/decl -InexactComplex (*Un -FloatComplex -SingleFlonumComplex))
-(define/decl -Complex (*Un -Real -Imaginary -ExactComplex -InexactComplex))
+(define/decl -ExactNumber (Un -ExactImaginary -ExactComplex -Rat))
+(define/decl -InexactImaginary (Un -FloatImaginary -SingleFlonumImaginary))
+(define/decl -Imaginary (Un -ExactImaginary -InexactImaginary))
+(define/decl -InexactComplex (Un -FloatComplex -SingleFlonumComplex))
+(define/decl -Complex (Un -Real -Imaginary -ExactComplex -InexactComplex))
 (define/decl -Number -Complex)
 
 ;; 80-bit floating-point numbers
@@ -329,9 +329,9 @@
               (lambda (x) (and (extflonum? x) (extfl>= x 0.0t0)))
               #f))
 
-(define/decl -ExtFlonumZero (*Un -ExtFlonumPosZero -ExtFlonumNegZero -ExtFlonumNan))
-(define/decl -PosExtFlonum (*Un -PosExtFlonumNoNan -ExtFlonumNan))
-(define/decl -NonNegExtFlonum (*Un -PosExtFlonum -ExtFlonumZero))
-(define/decl -NegExtFlonum (*Un -NegExtFlonumNoNan -ExtFlonumNan))
-(define/decl -NonPosExtFlonum (*Un -NegExtFlonum -ExtFlonumZero))
-(define/decl -ExtFlonum (*Un -NegExtFlonumNoNan -ExtFlonumNegZero -ExtFlonumPosZero -PosExtFlonumNoNan -ExtFlonumNan))
+(define/decl -ExtFlonumZero (Un -ExtFlonumPosZero -ExtFlonumNegZero -ExtFlonumNan))
+(define/decl -PosExtFlonum (Un -PosExtFlonumNoNan -ExtFlonumNan))
+(define/decl -NonNegExtFlonum (Un -PosExtFlonum -ExtFlonumZero))
+(define/decl -NegExtFlonum (Un -NegExtFlonumNoNan -ExtFlonumNan))
+(define/decl -NonPosExtFlonum (Un -NegExtFlonum -ExtFlonumZero))
+(define/decl -ExtFlonum (Un -NegExtFlonumNoNan -ExtFlonumNegZero -ExtFlonumPosZero -PosExtFlonumNoNan -ExtFlonumNan))
diff --git a/typed-racket-lib/typed-racket/types/overlap.rkt b/typed-racket-lib/typed-racket/types/overlap.rkt
index ebe1373f..ad596b39 100644
--- a/typed-racket-lib/typed-racket/types/overlap.rkt
+++ b/typed-racket-lib/typed-racket/types/overlap.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "../utils/utils.rkt"
+         (utils hset)
          (rep type-rep rep-utils type-mask)
          (prefix-in c: (contract-req))
          (types abbrev subtype resolve utils)
@@ -40,8 +41,8 @@
 (define/cond-contract (overlap? t1 t2)
   (c:-> Type? Type? boolean?)
   (cond
-    [(type-equal? t1 t2) #t]
-    [(disjoint-masks? (Type-mask t1) (Type-mask t2)) #f]
+    [(equal? t1 t2) #t]
+    [(disjoint-masks? (mask t1) (mask t2)) #f]
     [(seen? t1 t2) #t]
     [else
      (with-updated-seen
@@ -58,15 +59,24 @@
                 (? App? s)))
          #:no-order
          (overlap? t (resolve-once s))]
-        [((? Mu? t) s) #:no-order (overlap? (unfold t) s)]
-        [((Refinement: t _) s) #:no-order (overlap? t s)]
-        [((Union: ts) s)
-         #:no-order
-         (ormap (λ (t) (overlap? t s)) ts)]
+        [((? Mu? t1) t2) #:no-order (overlap? (unfold t1) t2)]
+        [((Refinement: t1 _) t2) #:no-order (overlap? t1 t2)]
+        [((Union: ts1) t2)
+         (match t2
+           [(Union: ts2)
+            (or (hset-overlap? ts1 ts2)
+                (for*/or ([t1 (in-hset ts1)]
+                          [t2 (in-hset ts2)])
+                  (overlap? t1 t2)))]
+           [_ (or (hset-member? ts1 t2)
+                  (for/or ([t1 (in-hset ts1)])
+                    (overlap? t1 t2)))])]
+        [(t1 (Union: ts2))
+         (or (hset-member? ts2 t1)
+             (for/or ([t2 (in-hset ts2)]) (overlap? t1 t2)))]
         [((Intersection: ts) s)
          #:no-order
-         (for/and ([t (in-list ts)])
-           (overlap? t s))]
+         (for/and ([t (in-hset ts)]) (overlap? t s))]
         [((or (Poly-unsafe: _ t1)
               (PolyDots-unsafe: _ t1))
           t2)
diff --git a/typed-racket-lib/typed-racket/types/path-type.rkt b/typed-racket-lib/typed-racket/types/path-type.rkt
index 09cb4f10..a492b26a 100644
--- a/typed-racket-lib/typed-racket/types/path-type.rkt
+++ b/typed-racket-lib/typed-racket/types/path-type.rkt
@@ -4,9 +4,9 @@
          racket/match racket/set
          (contract-req)
          (rep object-rep type-rep values-rep)
-         (utils tc-utils)
+         (utils tc-utils hset)
          (typecheck renamer)
-         (types subtype resolve union)
+         (types subtype resolve)
          (except-in (types utils abbrev kw-types) -> ->* one-of/c))
 
 (require-for-cond-contract (rep rep-utils))
@@ -31,7 +31,7 @@
     (match* (t path)
       ;; empty path
       [(t (list)) t]
-    
+
       ;; pair ops
       [((Pair: t s) (cons (CarPE:) rst))
        (path-type rst t (hash))]
@@ -53,16 +53,13 @@
          (path-type rst ft (hash)))]
 
       [((Intersection: ts) _)
-       (apply -unsafe-intersect (for*/list ([t (in-list ts)]
+       (apply -unsafe-intersect (for*/list ([t (in-hset ts)]
                                             [t (in-value (path-type path t resolved))]
                                             #:when t)
                                   t))]
       [((Union: ts) _)
-       (apply Un (for*/list ([t (in-list ts)]
-                             [t (in-value (path-type path t resolved))]
-                             #:when t)
-                   t))]
-    
+       (Union-map ts (λ (t) (or (path-type path t resolved) -Bottom)))]
+
       ;; paths into polymorphic types
       ;; TODO can this expose unbound type indices... probably. It should be
       ;; shielded with a check for type indexes/variables/whatever.
@@ -70,7 +67,7 @@
       [((PolyDots: _ body-t) _) (path-type path body-t resolved)]
       [((PolyRow: _ _ body-t) _) (path-type path body-t resolved)]
       [((Distinction: _ _ t) _) (path-type path t resolved)]
-    
+
       ;; for private fields in classes
       [((Function: (list (arr: doms (Values: (list (Result: rng _ _))) _ _ _)))
         (cons (FieldPE:) rst))
@@ -78,8 +75,9 @@
 
       ;; types which need resolving
       [((? resolvable?) _) #:when (not (hash-ref resolved t #f))
-                           (path-type path (resolve-once t) (hash-set resolved t #t))]
-    
+       (path-type path (resolve-once t) (hash-set resolved t #t))]
+
       ;; type/path mismatch =(
       [(_ _) #f])))
 
+
diff --git a/typed-racket-lib/typed-racket/types/printer.rkt b/typed-racket-lib/typed-racket/types/printer.rkt
index 4e7e90ac..8d32a08e 100644
--- a/typed-racket-lib/typed-racket/types/printer.rkt
+++ b/typed-racket-lib/typed-racket/types/printer.rkt
@@ -13,11 +13,13 @@
                   "types/match-expanders.rkt"
                   "types/kw-types.rkt"
                   "types/utils.rkt" "types/abbrev.rkt"
+                  "types/union.rkt"
                   "types/resolve.rkt"
                   "types/prefab.rkt"
                   "utils/utils.rkt"
                   "utils/primitive-comparison.rkt"
-                  "utils/tc-utils.rkt")
+                  "utils/tc-utils.rkt"
+                  "utils/hset.rkt")
          (for-syntax racket/base syntax/parse))
 
 ;; printer-type: (one-of/c 'custom 'debug)
@@ -65,7 +67,7 @@
 (define (has-name? t)
   (define candidates
     (for/list ([(n t*) (in-dict (force (current-type-names)))]
-               #:when (and print-aliases (Type? t*) (type-equal? t t*)))
+               #:when (and print-aliases (Type? t*) (equal? t t*)))
       n))
   (and (pair? candidates)
        (sort candidates string>? #:key symbol->string #:cache-keys? #t)))
@@ -165,13 +167,13 @@
 ;; We do set coverage, with the elements of the union being what we want to
 ;; cover, and all the names types we know about being the sets.
 (define (cover-union t ignored-names)
-  (match-define (Union: elems) t)
+  (match-define (Union: (app hset->list elems)) t)
   (define valid-names
     ;; We keep only unions, and only those that are subtypes of t.
     ;; It's no use attempting to cover t with things that go outside of t.
     (filter (lambda (p)
               (match p
-                [(cons name (and t* (Union: elts)))
+                [(cons name (? Union? t*))
                  (and (not (member name ignored-names))
                       (subtype t* t))]
                 [_ #f]))
@@ -180,7 +182,7 @@
   ;; note that racket/set supports lists with equal?, which in
   ;; the case of Types will be type-equal?
   (define candidates
-    (map (match-lambda [(cons name (Union: elts)) (cons name elts)])
+    (map (match-lambda [(cons name (Union: (app hset->list elts))) (cons name elts)])
          valid-names))
   ;; some types in the union may not be coverable by the candidates
   ;; (e.g. type variables, etc.)
@@ -487,16 +489,15 @@
     [(MPairTop:) 'MPairTop]
     [(Prompt-TagTop:) 'Prompt-TagTop]
     [(Continuation-Mark-KeyTop:) 'Continuation-Mark-KeyTop]
-    [(App: rator rands stx)
+    [(App: rator rands)
      (list* (type->sexp rator) (map type->sexp rands))]
     ;; Special cases for lists. Avoid printing with these cases if the
     ;; element type refers to the Mu variable (otherwise it prints the
     ;; type variable with no binding).
-    [(Listof: elem-ty var)
-     #:when (not (memq var (fv elem-ty)))
+    [(SimpleListof: elem-ty)
+     ;; in the 'elem-ty' type
      `(Listof ,(t->s elem-ty))]
-    [(MListof: elem-ty var)
-     #:when (not (memq var (fv elem-ty)))
+    [(SimpleMListof: elem-ty)
      `(MListof ,(t->s elem-ty))]
     ;; format as a string to preserve reader abbreviations and primitive
     ;; values like characters (when `display`ed)
@@ -526,10 +527,13 @@
     [(CustodianBox: e) `(CustodianBoxof ,(t->s e))]
     [(Set: e) `(Setof ,(t->s e))]
     [(Evt: r) `(Evtof ,(t->s r))]
-    [(Union: elems)
-     (define-values (covered remaining) (cover-union type ignored-names))
-     (cons 'U (sort (append covered (map t->s remaining)) primitive<=?))]
-    [(Intersection: elems)
+    [(? Union? (app normalize-type type))
+     (match type
+       [(? Union?)
+        (define-values (covered remaining) (cover-union type ignored-names))
+        (cons 'U (sort (append covered (map t->s remaining)) primitive<=?))]
+       [_ (t->s type)])]
+    [(Intersection: (app hset->list elems))
      (cons '∩ (sort (map t->s elems) primitive<=?))]
     [(Pair: l r) `(Pairof ,(t->s l) ,(t->s r))]
     [(ListDots: dty dbound) `(List ,(t->s dty) ... ,dbound)]
@@ -563,7 +567,8 @@
                               (Vector: (F: x))
                               (Box: (F: x))))))
      'Syntax]
-    [(Mu-name: name body) `(Rec ,name ,(t->s body))]
+    [(Mu-name: name body)
+     `(Rec ,name ,(t->s body))]
     [(B: idx) `(B ,idx)]
     [(Syntax: t) `(Syntaxof ,(t->s t))]
     [(Instance: (and (? has-name?) cls)) `(Instance ,(t->s cls))]
@@ -577,6 +582,7 @@
        (export ,@(map signature->sexp exports))
        (init-depend ,@(map signature->sexp init-depends))
        ,(values->sexp body))]
+    [(UnitTop:) 'UnitTop]
     [(MPair: s t) `(MPairof ,(t->s s) ,(t->s t))]
     [(Refinement: parent p?)
      `(Refinement ,(t->s parent) ,(syntax-e p?))]
diff --git a/typed-racket-lib/typed-racket/types/prop-ops.rkt b/typed-racket-lib/typed-racket/types/prop-ops.rkt
index 442c2603..1fedd191 100644
--- a/typed-racket-lib/typed-racket/types/prop-ops.rkt
+++ b/typed-racket-lib/typed-racket/types/prop-ops.rkt
@@ -6,19 +6,21 @@
          (rep type-rep prop-rep object-rep values-rep rep-utils)
          (only-in (infer infer) intersect)
          compatibility/mlist
-         (types union subtype overlap subtract abbrev tc-result))
+         racket/set
+         (types subtype overlap subtract abbrev tc-result union))
 
 (provide/cond-contract
   [-and (c:->* () #:rest (c:listof Prop?) Prop?)]
   [-or (c:->* () #:rest (c:listof Prop?) Prop?)]
   [implies-atomic? (c:-> Prop? Prop? boolean?)]
+  [implies? (c:-> Prop? Prop? boolean?)]
+  [prop-equiv? (c:-> Prop? Prop? boolean?)]
   [negate-prop (c:-> Prop? Prop?)]
   [complementary? (c:-> Prop? Prop? boolean?)]
   [contradictory? (c:-> Prop? Prop? boolean?)]
   [add-unconditional-prop-all-args (c:-> Function? Type? Function?)]
   [add-unconditional-prop (c:-> tc-results/c Prop? tc-results/c)]
   [erase-props (c:-> tc-results/c tc-results/c)]
-  [name-ref=? (c:-> name-ref/c name-ref/c boolean?)]
   [reduce-propset/type (c:-> PropSet? Type? PropSet?)]
   [reduce-tc-results/subsumption (c:-> tc-results/c tc-results/c)])
 
@@ -27,8 +29,8 @@
 ;; its true proposition is -ff, etc)
 (define (reduce-propset/type ps t)
   (cond
-    [(type-equal? -Bottom t) -ff-propset]
-    [(type-equal? -False t) (-PS -ff (PropSet-els ps))]
+    [(Bottom? t) -ff-propset]
+    [(equal? -False t) (-PS -ff (PropSet-els ps))]
     [(not (overlap? t -False)) (-PS (PropSet-thn ps) -ff)]
     [else ps]))
 
@@ -48,12 +50,12 @@
        (define p- (if ps (PropSet-els ps) -tt))
        (define o (if obj obj -empty-obj))
        (cond
-         [(or (type-equal? -False t)
+         [(or (equal? -False t)
               (FalseProp? p+))
           (tc-result (intersect t -False) (-PS -ff p-) o)]
          [(not (overlap? t -False))
           (tc-result t (-PS p+ -ff) o)]
-         [(prop-equal? -ff p-) (tc-result (subtract t -False) (-PS p+ -ff) o)]
+         [(FalseProp? p-) (tc-result (subtract t -False) (-PS p+ -ff) o)]
          [else (tc-result t (-PS p+ p-) o)])]))
   (match res
     [(tc-any-results: _) res]
@@ -70,129 +72,117 @@
 ;; Returns true if the AND of the two props is equivalent to FalseProp
 (define (contradictory? p1 p2)
   (match* (p1 p2)
-    [((TypeProp: o1 t1) (TypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (not (overlap? t1 t2))]
     [((TypeProp: o1 t1) (NotTypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (subtype t1 t2)]
+     (and (eq? o1 o2) (subtype t1 t2))]
     [((NotTypeProp: o2 t2) (TypeProp: o1 t1))
-     #:when (object-equal? o1 o2)
-     (subtype t1 t2)]
-    [(_ _) (or (prop-equal? p1 -ff)
-               (prop-equal? p2 -ff))]))
+     (and (eq? o1 o2) (subtype t1 t2))]
+    [((FalseProp:) _) #t]
+    [(_ (FalseProp:)) #t]
+    [(_ _) #f]))
 
 ;; complementary: Prop? Prop? -> boolean?
 ;; Returns true if the OR of the two props is equivalent to Top
 (define (complementary? p1 p2)
   (match* (p1 p2)
     [((TypeProp: o1 t1) (NotTypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (subtype t2 t1)]
+     (and (eq? o1 o2) (subtype t2 t1))]
     [((NotTypeProp: o2 t2) (TypeProp: o1 t1))
-     #:when (object-equal? o1 o2)
-     (subtype t2 t1)]
-    [(_ _) (or (prop-equal? p1 -tt)
-               (prop-equal? p2 -tt))]))
-
-(define (name-ref=? a b)
-  (or (equal? a b)
-      (and (identifier? a)
-           (identifier? b)
-           (free-identifier=? a b))))
+     (and (eq? o1 o2) (subtype t2 t1))]
+    [((TrueProp:) _) #t]
+    [(_ (TrueProp:)) #t]
+    [(_ _) #f]))
 
 ;; does p imply q? (but only directly/simply)
+;; NOTE: because Ors and Atomic props are
+;; interned, we use eq? and memq
 (define (implies-atomic? p q)
   (match* (p q)
     ;; reflexivity
-    [(_ _) #:when (or (prop-equal? p q)
-                      (prop-equal? q -tt)
-                      (prop-equal? p -ff)) #t]
+    [(_ _) #:when (or (eq? p q)
+                      (TrueProp? q)
+                      (FalseProp? p)) #t]
     ;; ps ⊆ qs ?
     [((OrProp: ps) (OrProp: qs))
      (and (for/and ([p (in-list ps)])
-            (member p qs prop-equal?))
+            (memq p qs))
           #t)]
     ;; p ∈ qs ?
-    [(p (OrProp: qs)) (and (member p qs prop-equal?) #t)]
+    [(p (OrProp: qs)) (and (memq p qs) #t)]
     ;; q ∈ ps ?
-    [((AndProp: ps) q) (and (member q ps prop-equal?) #t)]
+    [((AndProp: ps) q) (or (equal? p q) (and (memq q ps) #t))]
     ;; t1 <: t2 ?
     [((TypeProp: o1 t1)
       (TypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (subtype t1 t2)]
+     (and (eq? o1 o2) (subtype t1 t2))]
     ;; t2 <: t1 ?
-    [((NotTypeProp: o1 t1) (NotTypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (subtype t2 t1)]
+    [((NotTypeProp: o1 t1)
+      (NotTypeProp: o2 t2))
+     (and (eq? o1 o2) (subtype t2 t1))]
     ;; t1 ∩ t2 = ∅ ?
-    [((TypeProp: o1 t1) (NotTypeProp: o2 t2))
-     #:when (object-equal? o1 o2)
-     (not (overlap? t1 t2))]
+    [((TypeProp:    o1 t1)
+      (NotTypeProp: o2 t2))
+     (and (eq? o1 o2) (not (overlap? t1 t2)))]
     ;; otherwise we give up
     [(_ _) #f]))
 
-;; intersect-update
-;; (mlist (mcons Object Type)) Object Type -> (mlist (mcons Object Type))
+(define (implies? p q)
+  (FalseProp? (-and p (negate-prop q))))
+
+(define (prop-equiv? p q)
+  (and (implies? p q)
+       (implies? q p)))
+
+;; helpers for compact 
+(define (intersect-update! dict t1 p)
+  (hash-update! dict p (λ (t2) (intersect t1 t2)) Univ))
+(define (union-update! dict t1 p)
+  (hash-update! dict p (λ (t2) (Un t1 t2)) -Bottom))
+
+;; compact : (listof prop) bool -> (listof prop)
+;; props : propositions to compress
+;; or? : is this an Or (alternative is And)
 ;;
-;; updates mutable association list 'dict' entry for 'o' w/ type t
-;; if no entry for 'o' is found, else if some previous type s is present
-;; update the type to t ∩ s
-(define (intersect-update dict o t)
-  (cond
-    [(massq o dict) => (λ (p)
-                         (set-mcdr! p (intersect t (mcdr p)))
-                         dict)]
-    [else (mcons (mcons o t) dict)]))
-
-
-;; union-update
-;; (mlist (mcons Object Type)) Object Type -> (mlist (mcons Object Type))
+;; This combines all the TypeProps at the same path into one TypeProp. If it is an Or the
+;; combination is done using Un, otherwise, intersect. The reverse is done for NotTypeProps.
+;; If it is an Or this simplifies to -tt if any of the atomic props simplified to -tt, and
+;; removes any -ff values. The reverse is done if this is an And.
 ;;
-;; updates mutable association list 'dict' entry for 'o' w/ type t
-;; if no entry for 'o' is found, else if some previous type s is present
-;; update the type to t ∪ s
-(define (union-update dict o t)
-  (cond
-    [(massq o dict) => (λ (p)
-                         (set-mcdr! p (Un t (mcdr p)))
-                         dict)]
-    [else (mcons (mcons o t) dict)]))
+;; NOTE: this is significantly faster as a macro than a function (even
+;; with define-inline)
+(define-syntax-rule (compact props or?)
+  (match props
+    [(or (list) (list _)) props]
+    [_
+     (define tf-map (make-hash))
+     (define ntf-map (make-hash))
 
-
-;; compact-or-props : (Listof prop) -> (Listof prop)
-;;
-;; This combines all the TypeProps at the same path into one TypeProp with Un, and
-;; all of the NotTypeProps at the same path into one NotTypeProp with intersect.
-;; The Or then simplifies to -tt if any of the atomic props simplified to -tt, and
-;; any values of -ff are removed.
-(define/cond-contract (compact-or-props props)
-  ((c:listof Prop?) . c:-> . (c:listof Prop?))
-  
-  (define-values (pos neg others)
-    (for/fold ([pos '()] [neg '()] [others '()])
-              ([prop (in-list props)])
-      (match prop
-        [(TypeProp: o t)
-         (values (union-update pos o t) neg others)]
-        [(NotTypeProp: o t)
-         (values pos (intersect-update neg o t) others)]
-        [_ (values pos neg (cons prop others))])))
-
-  
-  (let ([pos (for*/list ([p (in-mlist pos)]
-                         [p (in-value (-is-type (mcar p) (mcdr p)))]
-                         #:when (not (FalseProp? p)))
-               p)]
-        [neg (for*/list ([p (in-mlist neg)]
-                         [p (in-value (-not-type (mcar p) (mcdr p)))]
-                         #:when (not (FalseProp? p)))
-               p)])
-    (if (or (member -tt pos prop-equal?)
-            (member -tt neg prop-equal?))
-        (list -tt)
-        (append pos neg others))))
+     ;; consolidate type info and separate out other props
+     (define others
+       (for/fold ([others '()])
+                 ([prop (in-list props)])
+         (match prop
+           [(TypeProp: o t1)
+            ((if or? union-update! intersect-update!) tf-map t1 o)
+            others]
+           [(NotTypeProp: o t1)
+            ((if or? intersect-update! union-update!) ntf-map t1 o)
+            others]
+           [_ (cons prop others)])))
+     ;; convert consolidated types into props and gather everything
+     (define raw-results
+       (append (for/list ([(k v) (in-hash tf-map)])
+                 (-is-type k v))
+               (for/list([(k v) (in-hash ntf-map)])
+                 (-not-type k v))
+               others))
+     ;; check for abort condition and remove trivial props
+     (if or?
+         (if (member -tt raw-results)
+             (list -tt)
+             (filter-not FalseProp? raw-results))
+         (if (member -ff raw-results)
+             (list -ff)
+             (filter-not TrueProp? raw-results)))]))
 
 
 
@@ -214,31 +204,44 @@
 ;; will be a disjunction of only atomic propositions (i.e. a clause
 ;; in a CNF formula)
 (define (-or . args)
+  (define mk
+    (match-lambda [(list) -ff]
+                  [(list p) p]
+                  [ps (make-OrProp ps)]))
   (define (distribute args)
     (define-values (ands others) (partition AndProp? args))
-    (match ands
-      [(cons (AndProp: elems) ands)
-       (apply -and (for/list ([elem (in-list elems)])
-                     (apply -or elem (append ands others))))]
-      [_ (make-OrProp others)]))
-  (let loop ([ps args] [result null])
+    (if (null? ands)
+        (mk others)
+        (match-let ([(AndProp: elems) (car ands)])
+          (apply -and (for/list ([a (in-list elems)])
+                        (apply -or a (append (cdr ands) others)))))))
+  (define (flatten-ors/remove-duplicates ps)
+    (define results (mutable-set))
+    (for ([p (in-list ps)])
+      (match p
+        [(OrProp: ps*) (for ([p* (in-list ps*)])
+                         (set-add! results p*))]
+        [p (set-add! results p)]))
+    (set->list results))
+  (let loop ([ps (flatten-ors/remove-duplicates args)]
+             [result null])
     (match ps
-      [(cons p ps)
-       (match p
-         [(OrProp: ps*) (loop (append ps* ps) result)]
-         [(? FalseProp?) (loop ps result)]
-         [_
-          (let check-loop ([qs ps])
-            (match qs
-              [(cons q qs) (cond
-                             [(complementary? p q) -tt]
-                             [(implies-atomic? p q) (loop ps result)]
-                             [else (check-loop qs)])]
-              [_ #:when (for/or ([q (in-list result)])
-                          (implies-atomic? p q))
-                 (loop ps result)]
-              [_ (loop ps (cons p result))]))])]
-      [_ (distribute (compact-or-props result))])))
+      [(cons cur rst)
+       (cond
+         ;; trivial cases
+         [(TrueProp? cur) -tt]
+         [(FalseProp? cur) (loop rst result)]
+         ;; is there a complementary case e.g. (ϕ ∨ ¬ϕ)? if so abort
+         [(for/or ([p (in-list rst)])    (complementary? p cur)) -tt]
+         [(for/or ([p (in-list result)]) (complementary? p cur)) -tt]
+         ;; don't include 'cur' if its covered by another prop
+         [(for/or ([p (in-list rst)]) (implies-atomic? cur p))
+          (loop rst result)]
+         [(for/or ([p (in-list result)]) (implies-atomic? cur p))
+          (loop rst result)]
+         ;; otherwise keep 'cur' in this disjunction
+         [else (loop rst (cons cur result))])]
+      [_ (distribute (compact result #t))])))
 
 ;; -and
 ;; (listof Prop?) -> Prop?
@@ -247,47 +250,52 @@
 ;; will be a conjunction of only atomic propositions and disjunctions
 ;; (i.e. a CNF proposition)
 (define (-and . args)
-  (define-values (pos neg others)
-    (let loop ([args args]
-               [pos '()]
-               [neg '()]
-               [others '()])
-      (match args
-        [(cons arg args)
-         (match arg
-           [(TypeProp: o t) (loop args (intersect-update pos o t) neg others)]
-           [(NotTypeProp: o t) (loop args pos (union-update neg o t) others)]
-           [(AndProp: ps)
-            (let-values ([(pos neg others) (loop ps pos neg others)])
-              (loop args pos neg others))]
-           [_ (loop args pos neg (cons arg others))])]
-        [_ (values pos neg others)])))
-  ;; Move all the type props up front as they are the stronger props
-  (let loop ([ps (append (for*/list ([p (in-mlist pos)]
-                                     [p (in-value (-is-type (mcar p) (mcdr p)))]
-                                     #:when (not (prop-equal? -tt p)))
-                           p)
-                         (for*/list ([p (in-mlist neg)]
-                                     [p (in-value (-not-type (mcar p) (mcdr p)))]
-                                     #:when (not (prop-equal? -tt p)))
-                           p)
-                         others)]
+  (define mk
+    (match-lambda [(list) -tt]
+                  [(list p) p]
+                  [ps (make-AndProp ps)]))
+  ;; we remove duplicates and organize the props so that the
+  ;; strongest ones come first (note: this includes considering
+  ;; smaller ors before larger ors)
+  (define (flatten-ands/remove-duplicates/order ps)
+    (define ts (mutable-set))
+    (define nts (mutable-set))
+    (define ors (make-hash))
+    (define others (mutable-set))
+    (let partition! ([ps ps])
+      (for ([p (in-list ps)])
+        (match p
+          [(? TypeProp?) (set-add! ts p)]
+          [(? NotTypeProp?) (set-add! nts p)]
+          [(OrProp: ps*) (hash-update! ors (length ps*) (λ (l) (cons p l)) '())]
+          [(AndProp: ps*) (partition! ps*)]
+          [_ (set-add! others p)])))
+    (define ors-smallest-to-largest
+      (append-map cdr (sort (hash->list ors)
+                            (λ (len/ors1 len/ors2)
+                              (< (car len/ors1) (car len/ors2))))))
+    (append (set->list ts)
+            (set->list nts)
+            (set->list others)
+            ors-smallest-to-largest))
+  (let loop ([ps (flatten-ands/remove-duplicates/order args)]
              [result null])
     (match ps
-      [(cons p ps)
+      [(cons cur rst)
        (cond
-         [(let check-loop ([qs ps])
-            (match qs
-              [(cons q qs) (cond
-                             [(contradictory? p q) -ff]
-                             [(implies-atomic? q p) (loop ps result)]
-                             [else (check-loop qs)])]
-              [_ #f]))]
-         [(for/or ([q (in-list result)])
-            (implies-atomic? q p))
-          (loop ps result)]
-         [else (loop ps (cons p result))])]
-      [_ (make-AndProp result)])))
+         ;; trivial cases
+         [(FalseProp? cur) -ff]
+         [(TrueProp? cur) (loop rst result)]
+         ;; is there a contradition e.g. (ϕ ∧ ¬ϕ), if so abort
+         [(for/or ([p (in-list rst)])    (contradictory? p cur)) -ff]
+         [(for/or ([p (in-list result)]) (contradictory? p cur)) -ff]
+         ;; don't include 'cur' if its implied by another prop
+         ;; already in our result (this is why we order the props!)
+         [(for/or ([p (in-list result)]) (implies-atomic? p cur))
+          (loop rst result)]
+         ;; otherwise keep 'cur' in this conjunction
+         [else (loop rst (cons cur result))])]
+      [_ (mk (compact result #f))])))
 
 ;; add-unconditional-prop: tc-results? Prop? -> tc-results?
 ;; Ands the given proposition to the props in the tc-results.
@@ -297,14 +305,14 @@
     [(tc-any-results: f) (tc-any-results (-and prop f))]
     [(tc-results: ts (list (PropSet: ps+ ps-) ...) os)
      (ret ts
-          (for/list ([f+ (in-list ps+)]
-                     [f- (in-list ps-)])
-            (-PS (-and prop f+) (-and prop f-)))
+          (for/list ([p+ (in-list ps+)]
+                     [p- (in-list ps-)])
+            (-PS (-and prop p+) (-and prop p-)))
           os)]
     [(tc-results: ts (list (PropSet: ps+ ps-) ...) os dty dbound)
      (ret ts
-          (for/list ([f+ ps+] [f- ps-])
-            (-PS (-and prop f+) (-and prop f-)))
+          (for/list ([p+ (in-list ps+)] [p- (in-list ps-)])
+            (-PS (-and prop p+) (-and prop p-)))
           os
           dty
           dbound)]))
@@ -345,4 +353,4 @@
      (ret ts
           empties
           empties
-          dty dbound)]))
\ No newline at end of file
+          dty dbound)]))
diff --git a/typed-racket-lib/typed-racket/types/resolve.rkt b/typed-racket-lib/typed-racket/types/resolve.rkt
index 0cdfbbf8..89fa14cb 100644
--- a/typed-racket-lib/typed-racket/types/resolve.rkt
+++ b/typed-racket-lib/typed-racket/types/resolve.rkt
@@ -12,7 +12,9 @@
 (provide resolve-name resolve-app resolvable?
          resolve-app-check-error
          resolver-cache-remove!
-         current-check-polymorphic-recursion)
+         current-check-polymorphic-recursion
+         register-app-for-checking!
+         check-registered-apps!)
 (provide/cond-contract
  [resolve-once (Type? . -> . (or/c Type? #f))]
  [resolve (Type? . -> . Type?)])
@@ -38,6 +40,29 @@
 
 (define already-resolving? (make-parameter #f))
 
+;; list of (cons/c App? syntax?) of parsed Apps
+;; during early phase of typechecking,
+;; `check-registered-apps!` consumes these to verify
+;; they are correct
+(define apps-to-check (box '()))
+
+;; registers an App for checking
+;; used while parsing types initially,
+;; once all definitions are loaded, we can verify
+;; Apps are well formed (i.e. take the correct number of args, etc)
+(define (register-app-for-checking! app stx)
+  (set-box! apps-to-check
+            (cons (cons app stx)
+                  (unbox apps-to-check))))
+
+;; checks apps registered with `register-app-for-checking!`
+(define (check-registered-apps!)
+  (for* ([p (in-list (unbox apps-to-check))]
+         [(app stx) (in-pair p)])
+    (match app
+      [(App: (? Name? rator) rands)
+       (resolve-app-check-error rator rands stx)]))
+  (set-box! apps-to-check '()))
 
 (define (resolve-app-check-error rator rands stx)
   (parameterize ([current-orig-stx stx])
@@ -54,7 +79,7 @@
        (define poly-num (length (poly-vars (current-poly-struct))))
        (if (= poly-num (length rands))
            (when (not (or (ormap Error? rands)
-                          (andmap type-equal? rands
+                          (andmap equal? rands
                                   (poly-vars (current-poly-struct)))))
              (tc-error (~a "structure type constructor applied to non-regular arguments"
                            "\n  type: " rator
@@ -112,25 +137,27 @@
                  [var (in-list current-vars)])
             (check-argument rand var))]
          [_ (void)])]
-      [(Mu: _ _) (void)]
-      [(App: _ _ _) (void)]
-      [(Error:) (void)]
+      [(? Mu?) (void)]
+      [(? App?) (void)]
+      [(? Error?) (void)]
       [_ (tc-error/delayed (~a "type cannot be applied"
                                "\n  type: " rator
                                "\n  arguments...: " rands))])))
 
 
-(define (resolve-app rator rands stx)
-  (parameterize ([current-orig-stx stx]
+(define (resolve-app rator rands [stx #f])
+  (parameterize ([current-orig-stx (or stx (current-orig-stx))]
                  [already-resolving? #t])
     (resolve-app-check-error rator rands stx)
     (match rator
       [(? Name?)
        (let ([r (resolve-name rator)])
          (and r (resolve-app r rands stx)))]
-      [(Poly: _ _) (instantiate-poly rator rands)]
-      [(Mu: _ _) (resolve-app (unfold rator) rands stx)]
-      [(App: r r* s) (resolve-app (resolve-app r r* s) rands stx)]
+      [(? Poly?) (instantiate-poly rator rands)]
+      [(? Mu?) (resolve-app (unfold rator) rands stx)]
+      [(App: r r*) (resolve-app (resolve-app r r* (current-orig-stx))
+                                rands
+                                (current-orig-stx))]
       [_ (tc-error (~a "cannot apply a non-polymorphic type"
                        "\n  type: " rator
                        "\n  arguments: " rands))])))
@@ -145,7 +172,7 @@
   (or r
       (let ([r* (match t
                   [(Mu: _ _) (unfold t)]
-                  [(App: r r* s) (resolve-app r r* s)]
+                  [(App: r r*) (resolve-app r r* #f)]
                   [(? Name?) (resolve-name t)])])
         (when (and r* (not (currently-subtyping?)))
           (hash-set! resolver-cache t r*))
diff --git a/typed-racket-lib/typed-racket/types/substitute.rkt b/typed-racket-lib/typed-racket/types/substitute.rkt
index 3beab6f1..d8d06de1 100644
--- a/typed-racket-lib/typed-racket/types/substitute.rkt
+++ b/typed-racket-lib/typed-racket/types/substitute.rkt
@@ -78,7 +78,7 @@
           (λ (name)
             (int-err "substitute used on ... variable ~a in type ~a" name target))]
          [else (make-ListDots (sub dty) dbound)])]
-      [_ (Rep-fold sub target)])))
+      [_ (Rep-fmap target sub)])))
 
 
 
@@ -137,7 +137,7 @@
                     (and rest (sub rest))
                     (and drest (cons (sub (car drest)) (cdr drest)))
                     (map sub kws))])]
-      [_ (Rep-fold sub target)])))
+      [_ (Rep-fmap target sub)])))
 
 ;; implements curly brace substitution from the formalism, with the addition
 ;; that a substitution can include fixed args in addition to a different dotted arg
@@ -177,7 +177,7 @@
                                  image-bound]
                                 [else (cdr drest)])))
                    (map sub kws)))]
-      [_ (Rep-fold sub target)])))
+      [_ (Rep-fmap target sub)])))
 
 ;; substitute many variables
 ;; subst-all : substitution/c Type -> Type
diff --git a/typed-racket-lib/typed-racket/types/subtract.rkt b/typed-racket-lib/typed-racket/types/subtract.rkt
index ec4c1dd7..2a4710b3 100644
--- a/typed-racket-lib/typed-racket/types/subtract.rkt
+++ b/typed-racket-lib/typed-racket/types/subtract.rkt
@@ -1,9 +1,10 @@
 #lang racket/base
 
 (require "../utils/utils.rkt"
+         (utils hset)
          (rep type-rep rep-utils type-mask)
-         (types abbrev union subtype resolve utils)
-         racket/match racket/set)
+         (types abbrev subtype resolve utils)
+         racket/match)
 
 (provide subtract)
 
@@ -16,15 +17,15 @@
   (define result
     (let sub ([t t])
       (match t
-        [_ #:when (disjoint-masks? (Type-mask t) (Type-mask s)) t]
+        [_ #:when (disjoint-masks? (mask t) (mask s)) t]
         [_ #:when (subtype t s) -Bottom]
-        [(or (App: _ _ _) (? Name?))
+        [(or (App: _ _) (? Name?))
          ;; must be different, since they're not subtypes
          ;; and n must refer to a distinct struct type
          t]
-        [(Union: elems) (apply Un (map sub elems))]
+        [(Union: elems) (Union-map elems sub)]
         [(Intersection: ts)
-         (apply -unsafe-intersect (set-map ts sub))]
+         (apply -unsafe-intersect (hset-map ts sub))]
         [(? Mu?) (sub (unfold t))]
         [(Poly: vs b) (make-Poly vs (sub b))]
         [_ t])))
diff --git a/typed-racket-lib/typed-racket/types/subtype.rkt b/typed-racket-lib/typed-racket/types/subtype.rkt
index 7a83058b..adcbfe5a 100644
--- a/typed-racket-lib/typed-racket/types/subtype.rkt
+++ b/typed-racket-lib/typed-racket/types/subtype.rkt
@@ -5,8 +5,8 @@
          (contract-req)
          (rep type-rep prop-rep object-rep
               core-rep type-mask values-rep rep-utils
-              free-variance)
-         (utils tc-utils early-return)
+              free-variance rep-switch)
+         (utils tc-utils hset)
          (types utils resolve match-expanders current-seen
                 numeric-tower substitute prefab signatures)
          (for-syntax racket/base syntax/parse racket/sequence)
@@ -15,7 +15,6 @@
                     [->* t->*]))
 
 (lazy-require
-  ("union.rkt" (Un))
   ("../infer/infer.rkt" (infer))
   ("../typecheck/tc-subst.rkt" (restrict-values)))
 
@@ -36,8 +35,7 @@
 ;; is t1 a subtype of t2?
 ;; type type -> boolean
 (define (subtype t1 t2)
-  (define res (and (subtype* (seen) t1 t2) #t))
-  res)
+  (and (subtype* (seen) t1 t2) #t))
 
 
 ;; is v1 a subval of v2?
@@ -277,7 +275,7 @@
                   (app resolve-once (? Struct? i)))
              (App: (and (Name/struct:)
                         (app resolve-once (Poly: _ (? Struct? i))))
-                   _ _))])))
+                   _))])))
 
 (define (subtype/flds* A flds flds*)
   (for/fold ([A A])
@@ -374,6 +372,25 @@
 	       (subtype* t1 t2)
 	       (subtype* t2 t1)))
 
+(define union-super-cache (make-weak-hasheq))
+(define union-sub-cache (make-weak-hasheq))
+
+;; cache-set!
+;; caches 'result' as the answer for 't1 <: t2'
+(define/cond-contract (cache-set! cache t1 t2 result)
+  (-> hash? Type? Type? boolean? void?)
+  (hash-set! (hash-ref cache t1 (λ () (make-weak-hash))) t2 (box-immutable result)))
+
+;; cache-ref
+;; checks if 't1 <: t2 = b' has already been calculated
+;; and if so, returning (box b), otherwise return #f
+(define/cond-contract (cache-ref cache t1 t2)
+  (-> hash? Type? Type? (or/c #f (box/c boolean?)))
+  (cond
+    [(hash-ref cache t1 #f)
+     => (λ (inner-cache) (hash-ref inner-cache t2 #f))]
+    [else #f]))
+
 ;; the algorithm for recursive types transcribed directly from TAPL, pg 305
 ;; List[(cons Number Number)] type type -> List[(cons Number Number)] or #f
 ;; is s a subtype of t, taking into account previously seen pairs A
@@ -384,397 +401,560 @@
 ;; Instances, and Structs (Prefabs?)
 (define/cond-contract (subtype* A t1 t2)
   (-> (listof (cons/c Type? Type?)) Type? Type? (or/c #f list?))
-  (early-return
-   #:return-when (seen? t1 t2 A) A
-   #:return-when (Univ? t2) A
-   ;; error is top and bot
-   #:return-when (or (type-equal? t1 Err)
-                     (type-equal? t2 Err)) A
-   #:return-when (type-equal? t1 -Bottom) A
-   (define mask1 (Type-mask t1))
-   (define mask2 (Type-mask t2))
-   #:return-when (disjoint-masks? mask1 mask2) #f
-   #:return-when (type-equal? t1 t2) A
-   (define t1-subtype-cache (Type-subtype-cache t1))
-   (define cr (hash-ref t1-subtype-cache (Rep-seq t2) 'missing))
-   #:return-when (boolean? cr) (and cr A)
-   (define result
-     (match* (t1 t2)
-       ;; if this works, we're done, otherwise wait until after unions
-       ;; are explored to break the intersection apart
-       [((Intersection: t1s) _) #:when (for/or ([t1 (in-list t1s)])
-                                         (subtype* A t1 t2))
-                                A]
-       [(_ (Intersection: t2s))
+  (cond
+    [(Univ? t2) A]
+    [(Bottom? t1) A]
+    ;; error is top and bot
+    [(or (Error? t1) (Error? t2)) A]
+    [(disjoint-masks? (mask t1) (mask t2)) #f]
+    [(equal? t1 t2) A]
+    [(seen? t1 t2 A) A]
+    [else
+     ;; first we check on a few t2 cases
+     ;; that need to come early during checking
+     (match t2
+       [(Intersection: t2s)
         (for/fold ([A A])
-                  ([t2 (in-list t2s)]
+                  ([t2 (in-hset t2s)]
                    #:break (not A))
           (subtype* A t1 t2))]
-       ;; from define-new-subtype
-       [((Distinction: nm1 id1 t1) (app resolve (Distinction: nm2 id2 t2)))
-        #:when (and (equal? nm1 nm2) (equal? id1 id2))
-        (subtype* A t1 t2)]
-       [((Distinction: _ _ t1) t2) (subtype* A t1 t2)]
-       ;; tvars are equal if they are the same variable
-       [((F: var1) (F: var2)) (and (eq? var1 var2) A)]
-       ;; structural types of the same kind can be checked by simply
-       ;; referencing the field variances and performing the
-       ;; appropriate recursive calls
-       [((? structural? t1) (? structural? t2))
-        #:when (eq? (Rep-name t1)
-                    (Rep-name t2))
-        (for/fold ([A A])
-                  ([v (in-list (Type-variances t1))]
-                   [t1 (in-list (Rep-values t1))]
-                   [t2 (in-list (Rep-values t2))]
-                   #:break (not A))
-          (cond
-            [(eq? v Covariant)
-             (subtype* A t1 t2)]
-            [(eq? v Invariant)
-             (type-equiv? A t1 t2)]
-            [else ;; Contravariant
-             (subtype* A t2 t1)]))]
-       ;; If the type has a registered top type predicate, let's check it!
-       [((? has-top-type?) _) #:when ((top-type-pred t1) t2) A]
-       ;; quantification over two types preserves subtyping
-       [((Poly: ns b1) (Poly: ms b2))               
-        #:when (= (length ns) (length ms))
-        ;; substitute ns for ms in b2 to make it look like b1
-        (subtype* A b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))]
-       [((PolyDots: (list ns ... n-dotted) b1)
-         (PolyDots: (list ms ... m-dotted) b2))
-        (cond
-          [(< (length ns) (length ms))
-           (define-values (short-ms rest-ms) (split-at ms (length ns)))
-           ;; substitute ms for ns in b1 to make it look like b2
-           (define subst
-             (hash-set (make-simple-substitution ns (map make-F short-ms))
-                       n-dotted (i-subst/dotted (map make-F rest-ms) (make-F m-dotted) m-dotted)))
-           (subtype* A (subst-all subst b1) b2)]
-          [else
-           (define-values (short-ns rest-ns) (split-at ns (length ms)))
-           ;; substitute ns for ms in b2 to make it look like b1
-           (define subst
-             (hash-set (make-simple-substitution ms (map make-F short-ns))
-                       m-dotted (i-subst/dotted (map make-F rest-ns) (make-F n-dotted) n-dotted)))
-           (subtype* A b1 (subst-all subst b2))])]
-       [((PolyDots: (list ns ... n-dotted) b1)
-         (Poly: (list ms ...) b2))
-        #:when (<= (length ns) (length ms))
-        ;; substitute ms for ns in b1 to make it look like b2
-        (define subst
-          (hash-set (make-simple-substitution ns (map make-F (take ms (length ns))))
-                    n-dotted (i-subst (map make-F (drop ms (length ns))))))
-        (subtype* A (subst-all subst b1) b2)]
-       ;; use unification to see if we can use the polytype here
-       [((Poly: vs1 b1) _)
-        #:when (infer vs1 null (list b1) (list t2) Univ)
-        A]
-       [((PolyDots: (list vs1 ... vdotted1) b1) _)
-        #:when (infer vs1 (list vdotted1) (list b1) (list t2) Univ)
-        A]
-       [(_ (or (Poly:     vs2 b2)
-               (PolyDots: vs2 b2)))
-        #:when (null? (fv b2))
-        (subtype* A t1 b2)]
-       ;; recur structurally on dotted lists, assuming same bounds
-       [((ListDots: dty1 dbound1) (ListDots: dty2 dbound2))
-        (and (eq? dbound1 dbound2)
-             (subtype* A dty1 dty2))]
-       ;; For dotted lists and regular lists, we check that (All
-       ;; (dbound) s-dty) is a subtype of t-elem, so that no matter
-       ;; what dbound is instatiated with s-dty is still a subtype of
-       ;; t-elem. We cannot just replace dbound with Univ because of
-       ;; variance issues.
-       [((ListDots: dty1 dbound1) (Listof: t2-elem))
-        (subtype* A (-poly (dbound1) dty1) t2-elem)]
-       [((Value: v) (Base: _ _ pred _)) (if (pred v) A #f)]
-       [((? resolvable?) _)
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (let ([t1 (resolve-once t1)])
-              ;; check needed for if a name that hasn't been resolved yet
-              (and (Type? t1) (subtype* A t1 t2)))))]
-       [(_ (? resolvable?))
+       [(? resolvable?)
         (let ([A (remember t1 t2 A)])
           (with-updated-seen A
             (let ([t2 (resolve-once t2)])
               ;; check needed for if a name that hasn't been resolved yet
               (and (Type? t2) (subtype* A t1 t2)))))]
-       [((Union: elems) t)
-        (for/fold ([A A])
-                  ([elem (in-list elems)]
-                   #:break (not A))
-          (subtype* A elem t))]
-       [(s (Union: elems))
-        (and (ormap (λ (elem) (subtype* A s elem)) elems) A)]
-       ;; intersections as subtypes need to be handled after some forms (e.g. Unions)
-       ;; otherwise we will get the wrong answer for
-       ;; queries such as: (∩ A B) <: (U String (∩ A B))
-       [((Intersection: t1s) _)
-        (for/or ([t1 (in-list t1s)])
-          (subtype* A t1 t2))]
-       ;; Avoid needing to resolve things that refer to different structs.
-       ;; Saves us from non-termination
-       ;; Must happen *before* the sequence cases, which sometimes call `resolve' in match expanders
-       [((or (? Struct? s1) (NameStruct: s1))
-         (or (? Struct? s2) (NameStruct: s2)))
-        #:when (unrelated-structs s1 s2)
-        #f]
-       ;; same for all values.
-       [((Value: (? (negate struct?) _)) (or (? Struct? s1) (NameStruct: s1)))
-        #f]
-       [((or (? Struct? s1) (NameStruct: s1)) (Value: (? (negate struct?) _)))
-        #f]
-       ;; sequences are covariant
-       [((Sequence: ts1) (Sequence: ts2)) (subtypes* A ts1 ts2)]
-       [((Hashtable: k1 v1) (Sequence: (list k2 v2)))
-        (subtype-seq A
-                     (subtype* k1 k2)
-                     (subtype* v1 v2))]
-       ;; special-case for case-lambda/union with only one argument              
-       [((Function: arr1) (Function: (list arr2)))
-        (cond [(null? arr1) #f]
-              [else
-               (define comb (combine-arrs arr1))
-               (or (and comb (arr-subtype*/no-fail A comb arr2))
-                   (supertype-of-one/arr A arr2 arr1))])]
-       ;; case-lambda
-       [((Function: arrs1) (Function: arrs2))
-        (if (null? arrs1) #f
-            (let loop-arities ([A A]
-                               [arrs2 arrs2])
-              (cond
-                [(null? arrs2) A]
-                [(supertype-of-one/arr A (car arrs2) arrs1)
-                 => (λ (A) (loop-arities A (cdr arrs2)))]
-                [else #f])))]
-       [((Refinement: t1-parent _) _)
-        (subtype* A t1-parent t2)]
-       ;; subtyping on immutable structs is covariant
-       [((Struct: nm1 _ flds1 proc1 _ _) (Struct: nm2 _ flds2 proc2 _ _)) 
-        #:when (free-identifier=? nm1 nm2) 
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (let ([A (cond [(and proc1 proc2) (subtype* A proc1 proc2)]
-                           [proc2 #f]
-                           [else A])])
-              (and A (subtype/flds* A flds1 flds2)))))]
-       [((Struct: nm1 _ _ _ _ _) (StructTop: (Struct: nm2 _ _ _ _ _)))
-        #:when (free-identifier=? nm1 nm2)
-        A]
-       ;; vector special cases
-       [((HeterogeneousVector: elems1) (Vector: t2))
-        (for/fold ([A A])
-                  ([elem1 (in-list elems1)] #:break (not A))
-          (type-equiv? A elem1 t2))]
-       [((HeterogeneousVector: elems1) (HeterogeneousVector: elems2))
-        (cond [(= (length elems1)
-                  (length elems2))
-               (for/fold ([A A])
-                         ([elem1 (in-list elems1)]
-                          [elem2 (in-list elems2)]
-                          #:break (not A))
-                 (type-equiv? A elem1 elem2))]
-              [else #f])]
-       ;; subtyping on structs follows the declared hierarchy
-       [((Struct: nm1 (? Type? parent1) _ _ _ _) _)
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (subtype* A parent1 t2)))]
-       [((Prefab: k1 ss) (Prefab: k2 ts))
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (and (prefab-key-subtype? k1 k2)
-                 (and (>= (length ss) (length ts))
-                      (for/fold ([A A])
-                                ([s (in-list ss)]
-                                 [t (in-list ts)]
-                                 [mut? (in-list (prefab-key->field-mutability k2))]
-                                 #:break (not A))
-                        (and A
-                             (if mut?
-                                 (subtype-seq A
-                                              (subtype* t s)
-                                              (subtype* s t))
-                                 (subtype* A s t))))))))]
-       ;; subtyping on other stuff
-       [((Param: in1 out1) _)
-        (subtype* A (cl->* (t-> out1) (t-> in1 -Void)) t2)]
-       ;; homogeneous Sequence call helper for remaining cases
-       ;; that are subtypes of a homogeneous Sequence
-       [(_ (Sequence: (list seq-t))) (homo-sequence-subtype A t1 seq-t)]
-       ;; events call off to helper for remaining cases
-       [(_ (Evt: evt-t)) (event-subtype A t1 evt-t)]
-       [((Instance: (? resolvable? t1*)) _)
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (let ([t1* (resolve-once t1*)])
-              (and (Type? t1*)
-                   (subtype* A (make-Instance t1*) t2)))))]
-       [(_ (Instance: (? resolvable? t2*)))
-        (let ([A (remember t1 t2 A)])
-          (with-updated-seen A
-            (let ([t2* (resolve-once t2*)])
-              (and (Type? t2*)
-                   (subtype* A t1 (make-Instance t2*))))))]
-       [((Instance: (Class: _ _ field-map method-map augment-map _))
-         (Instance: (Class: _ _ field-map* method-map* augment-map* _)))
-        (define (subtype-clause? map map*)
-          (and (for/and ([key+type (in-list map*)])
-                 (match-define (list key type) key+type)
-                 (assq key map))
-               (let/ec escape
-                 (for/fold ([A A])
-                           ([key+type (in-list map)])
-                   (match-define (list key type) key+type)
-                   (define result (assq (car key+type) map*))
-                   (or (and (not result) A)
-                       (let ([type* (cadr result)])
-                         (or (subtype* A type type*)
-                             (escape #f))))))))
-        (and ;; Note that init & augment clauses don't matter for objects
-         (subtype-clause? method-map method-map*)
-         (subtype-clause? field-map field-map*))]
-       [((Class: row inits fields methods augments init-rest)
-         (Class: row* inits* fields* methods* augments* init-rest*))
-        ;; TODO: should the result be folded instead?
-        (define (sub t1 t2) (subtype* A t1 t2))
-        ;; check that each of inits, fields, methods, etc. are
-        ;; equal by sorting and checking type equality
-        (define (equal-clause? clause clause* [inits? #f])
-          (cond
-            [(not inits?)
-             (match-define (list (list names types) ...) clause)
-             (match-define (list (list names* types*) ...) clause*)
-             (and (= (length names) (length names*))
-                  (andmap equal? names names*)
-                  (andmap sub types types*))]
+       [_
+        (or
+         ;; then we try a switch on t1
+         (subtype-switch
+          t1 t2 A
+          ;; if we're still not certain after the switch,
+          ;; check the cases that need to come at the end
+          (λ (A t1 t2)
+            (match* (t1 t2)
+              [(t1 (Union: elems2))
+               (cond
+                 [(hset-member? elems2 t1) A]
+                 [(cache-ref union-super-cache t2 t1)
+                  => (λ (b) (and (unbox b) A))]
+                 [else
+                  (define result
+                    (for/or ([elem (in-hset elems2)])
+                      (and (subtype* A t1 elem) A)))
+                  (when (null? A)
+                    (cache-set! union-super-cache t2 t1 (and result #t)))
+                  result])]
+              [((Intersection: t1s) _)
+               (for/or ([t1 (in-hset t1s)])
+                 (subtype* A t1 t2))]
+              [(_ (Instance: (? resolvable? t2*)))
+               (let ([A (remember t1 t2 A)])
+                 (with-updated-seen A
+                   (let ([t2* (resolve-once t2*)])
+                     (and (Type? t2*)
+                          (subtype* A t1 (make-Instance t2*))))))]
+              [(_ (Poly: vs2 b2))
+               #:when (null? (fv b2))
+               (subtype* A t1 b2)]
+              [(_ (PolyDots: vs2 b2))
+               #:when (and (null? (fv b2))
+                           (null? (fi b2)))
+               (subtype* A t1 b2)]
+              [(_ _) #f]))))])]))
+
+
+
+(define-switch (subtype-switch t1 t2 A continue)
+  ;; NOTE: keep these in alphabetical order
+  ;; or ease of finding cases
+  [(case: App _)
+   (let ([A (remember t1 t2 A)])
+     (with-updated-seen A
+       (let ([t1 (resolve-once t1)])
+         ;; check needed for if a name that hasn't been resolved yet
+         (and (Type? t1) (subtype* A t1 t2)))))]
+  [(case: Async-Channel (Async-Channel: elem1))
+   (match t2
+     [(? Async-ChannelTop?) A]
+     [(Async-Channel: elem2) (type-equiv? A elem1 elem2)]
+     [(Evt: evt-t) (subtype* A elem1 evt-t)]
+     [_ (continue A t1 t2)])]
+  [(case: Base (Base: kind _ pred numeric?))
+   (match t2
+     [(Sequence: (list seq-t))
+      (cond
+        [(assq kind `((FlVector . ,-Flonum)
+                      (ExtFlVector . ,-ExtFlonum)
+                      (FxVector . ,-Fixnum)
+                      (String . ,-Char)
+                      (Bytes . ,-Byte)
+                      (Input-Port . ,-Nat)))
+         => (λ (p) (subtype* A (cdr p) seq-t))]
+        [numeric?
+         (define type
+           ;; FIXME: thread the store through here
+           (for/or ([num-t (in-list (list -Byte -Index -NonNegFixnum -Nat))])
+             (or (and (subtype* A t1 num-t) num-t))))
+         (if type
+             (subtype* A type seq-t)
+             #f)]
+        [else #f])]
+     [(Evt: evt-t)
+      (cond
+        [(memq kind '(Semaphore
+                      Output-Port
+                      Input-Port
+                      TCP-Listener
+                      Thread
+                      Subprocess
+                      Will-Executor))
+         (subtype* A t1 evt-t)]
+        ;; FIXME: change Univ to Place-Message-Allowed if/when that type is defined
+        [(and (Univ? evt-t) (memq kind '(Place Base-Place-Channel)))
+         A]
+        [(eq? kind 'LogReceiver) (subtype* A
+                                           (make-HeterogeneousVector
+                                            (list -Symbol -String Univ
+                                                  (Un (-val #f) -Symbol)))
+                                           evt-t)]
+        [else #f])]
+     [_ (continue A t1 t2)])]
+  [(case: Box (Box: elem1))
+   (match t2
+     [(? BoxTop?) A]
+     [(Box: elem2) (type-equiv? A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: Channel (Channel: elem1))
+   (match t2
+     [(? ChannelTop?) A]
+     [(Channel: elem2) (type-equiv? A elem1 elem2)]
+     [(Evt: evt-t) (subtype* A elem1 evt-t)]
+     [_ (continue A t1 t2)])]
+  [(case: Class (Class: row inits fields methods augments init-rest))
+   (match t2
+     [(? ClassTop?) A]
+     [(Class: row* inits* fields* methods* augments* init-rest*)
+      ;; TODO: should the result be folded instead?
+      (define (sub t1 t2) (subtype* A t1 t2))
+      ;; check that each of inits, fields, methods, etc. are
+      ;; equal by sorting and checking type equality
+      (define (equal-clause? clause clause* [inits? #f])
+        (cond
+          [(not inits?)
+           (match-define (list (list names types) ...) clause)
+           (match-define (list (list names* types*) ...) clause*)
+           (and (= (length names) (length names*))
+                (andmap equal? names names*)
+                (andmap sub types types*))]
+          [else
+           (match-define (list (list names types opt?) ...)
+             clause)
+           (match-define (list (list names* types* opt?*) ...)
+             clause*)
+           (and (= (length names) (length names*))
+                (andmap equal? names names*)
+                (andmap sub types types*)
+                (andmap equal? opt? opt?*))]))
+      ;; There is no non-trivial width subtyping on class types, but it's
+      ;; possible for two "equal" class types to look different
+      ;; in the representation. We deal with that here.
+      (and (or (and (or (Row? row) (not row))
+                    (or (Row? row*) (not row*)))
+               (equal? row row*))
+           (equal-clause? inits inits* #t)
+           (equal-clause? fields fields*)
+           (equal-clause? methods methods*)
+           (equal-clause? augments augments*)
+           (or (and init-rest init-rest*
+                    (sub init-rest init-rest*))
+               (and (not init-rest) (not init-rest*)
+                    A)))]
+     [_ (continue A t1 t2)])]
+  [(case: Continuation-Mark-Keyof (Continuation-Mark-Keyof: val1))
+   (match t2
+     [(? Continuation-Mark-KeyTop?) A]
+     [(Continuation-Mark-Keyof: val2)
+      (type-equiv? A val1 val2)]
+     [_ (continue A t1 t2)])]
+  [(case: CustodianBox (CustodianBox: elem1))
+   (match t2
+     [(CustodianBox: elem2) (subtype* A elem1 elem2)]
+     [(Evt: evt-t)
+      ;; Note that it's the whole box type that's being
+      ;; compared against evt-t here
+      (subtype* A t1 evt-t)]
+     [_ (continue A t1 t2)])]
+  [(case: Distinction (Distinction: nm1 id1 t1*))
+   (match t2
+     [(app resolve (Distinction: nm2 id2 t2*))
+      #:when (and (equal? nm1 nm2) (equal? id1 id2))
+      (subtype* A t1* t2*)]
+     [_ (cond
+          [(subtype* A t1* t2)]
+          [else (continue A t1 t2)])])]
+  [(case: Ephemeron (Ephemeron: elem1))
+   (match t2
+     [(Ephemeron: elem2) (subtype* A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: Evt (Evt: result1))
+   (match t2
+     [(Evt: result2) (subtype* A result1 result2)]
+     [_ (continue A t1 t2)])]
+  [(case: F (F: var1))
+   (match t2
+     ;; tvars are equal if they are the same variable
+     [(F: var2) (eq? var1 var2)]
+     [_ (continue A t1 t2)])]
+  [(case: Function (Function: arrs1))
+   (match t2
+     ;; special-case for case-lambda/union with only one argument              
+     [(Function: (list arr2))
+      (cond [(null? arrs1) #f]
             [else
-             (match-define (list (list names types opt?) ...)
-               clause)
-             (match-define (list (list names* types* opt?*) ...)
-               clause*)
-             (and (= (length names) (length names*))
-                  (andmap equal? names names*)
-                  (andmap sub types types*)
-                  (andmap equal? opt? opt?*))]))
-        ;; There is no non-trivial width subtyping on class types, but it's
-        ;; possible for two "equal" class types to look different
-        ;; in the representation. We deal with that here.
-        (and (or (and (or (Row? row) (not row))
-                      (or (Row? row*) (not row*)))
-                 (equal? row row*))
-             (equal-clause? inits inits* #t)
-             (equal-clause? fields fields*)
-             (equal-clause? methods methods*)
-             (equal-clause? augments augments*)
-             (or (and init-rest init-rest*
-                      (sub init-rest init-rest*))
-                 (and (not init-rest) (not init-rest*)
-                      A)))]
-       ;; For Unit types invoke-types are covariant
-       ;; imports and init-depends are covariant in that importing fewer
-       ;; signatures results in a subtype
-       ;; exports conversely are contravariant, subtypes export more signatures
-       [((Unit: imports1 exports1 init-depends1 t1)
-         (Unit: imports2 exports2 init-depends2 t2))
-        (and (check-sub-signatures? imports2 imports1)
-             (check-sub-signatures? exports1 exports2)
-             (check-sub-signatures? init-depends2 init-depends1)
-             (subval* A t1 t2))]
-       ;; otherwise, not a subtype
-       [(_ _) #f]))
-   (when (null? A) (hash-set! t1-subtype-cache (Rep-seq t2) (and result #t)))
-   result))
-
-;;************************************************************
-;; Other Subtyping Special Cases
-;;************************************************************
-
-(define seq-base-types `((FlVector . ,-Flonum)
-                         (ExtFlVector . ,-ExtFlonum)
-                         (FxVector . ,-Fixnum)
-                         (String . ,-Char)
-                         (Bytes . ,-Byte)
-                         (Input-Port . ,-Nat)))
-
-;; Homo-sequence-subtype
-;; is t a subtype of (Sequence: seq-t)?
-(define/cond-contract (homo-sequence-subtype A t seq-t)
-  (-> list? Type? Type? any/c)
-  (match t
-    [(Pair: t1 t2)
-     (subtype-seq A
-                  (subtype* t1 seq-t)
-                  (subtype* t2 (-lst seq-t)))]
-    ;; To check that mutable pair is a sequence we check that the cdr
-    ;; is both an mutable list and a sequence
-    [(MPair: t1 t2)
-     (subtype-seq A
-                  (subtype* t1 seq-t)
-                  (subtype* t2 (simple-Un -Null (make-MPairTop)))
-                  (subtype* t2 (make-Sequence (list seq-t))))]
-    [(Value: '()) A]
-    [(HeterogeneousVector: ts)
-     (subtypes* A ts (make-list (length ts) seq-t))]
-    [(or (Vector: t) (Set: t)) (subtype* A t seq-t)]
-    [(Base: kind _ _ _) #:when (assq kind seq-base-types)
-     (subtype* A (cdr (assq kind seq-base-types)) seq-t)]
-    [(Value: (? exact-nonnegative-integer? n))
-     (define possibilities
-       (list
-        (list byte? -Byte)
-        (list portable-index? -Index)
-        (list portable-fixnum? -NonNegFixnum)
-        (list values -Nat)))
-     (define type
-       (for/or ((pred-type (in-list possibilities)))
-         (match pred-type
-           ((list pred? type)
-            (and (pred? n) type)))))
-     (subtype* A type seq-t)]
-    [(Base: _ _ _ #t)
-     (define type
-       ;; FIXME: thread the store through here
-       (for/or ((num-t (in-list (list -Byte -Index -NonNegFixnum -Nat))))
-         (or (and (subtype* A t num-t) num-t))))
-     (if type
-         (subtype* A type seq-t)
-         #f)]
-    [_ #f]))
-
-
-;; event-subtype
-;; returns if t is a subtype of (Evt: evt-t)
-(define/cond-contract (event-subtype A t evt-t)
-  (-> list? Type? Type? (or/c list? #f))
-  (match t
-    [(Base: kind _ _ _) #:when (memq kind '(Semaphore
-                                            Output-Port
-                                            Input-Port
-                                            TCP-Listener
-                                            Thread
-                                            Subprocess
-                                            Will-Executor))
-     (subtype* A t evt-t)]
-    ;; FIXME: change Univ to Place-Message-Allowed if/when that type is defined
-    [(Base: kind _ _ _) #:when (and (Univ? evt-t)
-                                    (memq kind '(Place Base-Place-Channel)))
-     A]
-    [(Base: 'LogReceiver _ _ _)
-     (subtype* A
-               (make-HeterogeneousVector
-                (list -Symbol -String Univ
-                      (Un (-val #f) -Symbol)))
-               evt-t)]
-    [(CustodianBox: _)
-     ;; Note that it's the whole box type that's being
-     ;; compared against t* here
-     (subtype* A t evt-t)]
-    [(or (Channel: t)
-         (Async-Channel: t))
-     (subtype* A t evt-t)]
-    [_ #f]))
-
+             (define comb (combine-arrs arrs1))
+             (or (and comb (arr-subtype*/no-fail A comb arr2))
+                 (supertype-of-one/arr A arr2 arrs1))])]
+     ;; case-lambda
+     [(Function: arrs2)
+      (if (null? arrs1) #f
+          (let loop-arities ([A A]
+                             [arrs2 arrs2])
+            (cond
+              [(null? arrs2) A]
+              [(supertype-of-one/arr A (car arrs2) arrs1)
+               => (λ (A) (loop-arities A (cdr arrs2)))]
+              [else #f])))]
+     [_ (continue A t1 t2)])]
+  [(case: Future (Future: elem1))
+   (match t2
+     [(Future: elem2) (subtype* A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: Hashtable (Hashtable: key1 val1))
+   (match t2
+     [(? HashtableTop?) A]
+     [(Hashtable: key2 val2) (subtype-seq A
+                                          (type-equiv? key1 key2)
+                                          (type-equiv? val1 val2))]
+     [(Sequence: (list key2 val2))
+      (subtype-seq A
+                   (subtype* key1 key2)
+                   (subtype* val1 val2))]
+     [_ (continue A t1 t2)])]
+  [(case: HeterogeneousVector (HeterogeneousVector: elems1))
+   (match t2
+     [(VectorTop:) A]
+     [(HeterogeneousVector: elems2)
+      (cond [(= (length elems1)
+                (length elems2))
+             (for/fold ([A A])
+                       ([elem1 (in-list elems1)]
+                        [elem2 (in-list elems2)]
+                        #:break (not A))
+               (type-equiv? A elem1 elem2))]
+            [else #f])]
+     [(Vector: elem2)
+      (for/fold ([A A])
+                ([elem1 (in-list elems1)] #:break (not A))
+        (type-equiv? A elem1 elem2))]
+     [(Sequence: (list seq-t))
+      (for/fold ([A A])
+                ([elem1 (in-list elems1)]
+                 #:break (not A))
+        (subtype* A elem1 seq-t))]
+     [_ (continue A t1 t2)])]
+  [(case: Instance (Instance: inst-t1))
+   (cond
+     [(resolvable? inst-t1)
+      (let ([A (remember t1 t2 A)])
+        (with-updated-seen A
+          (let ([t1* (resolve-once inst-t1)])
+            (and (Type? t1*)
+                 (subtype* A (make-Instance t1*) t2)))))]
+     [else
+      (match* (t1 t2)
+        [((Instance: (Class: _ _ field-map method-map augment-map _))
+          (Instance: (Class: _ _ field-map* method-map* augment-map* _)))
+         (define (subtype-clause? map map*)
+           (and (for/and ([key+type (in-list map*)])
+                  (match-define (list key type) key+type)
+                  (assq key map))
+                (let/ec escape
+                  (for/fold ([A A])
+                            ([key+type (in-list map)])
+                    (match-define (list key type) key+type)
+                    (define result (assq (car key+type) map*))
+                    (or (and (not result) A)
+                        (let ([type* (cadr result)])
+                          (or (subtype* A type type*)
+                              (escape #f))))))))
+         (and ;; Note that init & augment clauses don't matter for objects
+          (subtype-clause? method-map method-map*)
+          (subtype-clause? field-map field-map*))]
+        [(_ _) (continue A t1 t2)])])]
+  [(case: Intersection (Intersection: t1s))
+   (cond
+     [(for/or ([t1 (in-hset t1s)])
+        (subtype* A t1 t2))]
+     [else (continue A t1 t2)])]
+  [(case: ListDots (ListDots: dty1 dbound1))
+   (match t2
+     ;; recur structurally on dotted lists, assuming same bounds
+     [(ListDots: dty2 dbound2)
+      (and (eq? dbound1 dbound2)
+           (subtype* A dty1 dty2))]
+     ;; For dotted lists and regular lists, we check that (All
+     ;; (dbound1) dty1) is a subtype of elem2, so that no matter
+     ;; what dbound is instatiated with dty1 is still a subtype of
+     ;; elem2. We cannot just replace dbound with Univ because of
+     ;; variance issues.
+     [(Listof: elem2)
+      (subtype* A (-poly (dbound1) dty1) elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: MPair (MPair: t11 t12))
+   (match t2
+     [(? MPairTop?) A]
+     [(MPair: t21 t22)
+      (subtype-seq A
+                   (type-equiv? t11 t21)
+                   (type-equiv? t12 t22))]
+     ;; To check that mutable pair is a sequence we check that the cdr
+     ;; is both an mutable list and a sequence 
+     [(Sequence: (list seq-t))
+      (subtype-seq A
+                   (subtype* t11 seq-t)
+                   (subtype* t12 (Un -Null -MPairTop))
+                   (subtype* t12 (make-Sequence (list seq-t))))]
+     [_ (continue A t1 t2)])]
+  [(case: Mu _)
+   (let ([A (remember t1 t2 A)])
+     (with-updated-seen A
+       (let ([t1 (unfold t1)])
+         ;; check needed for if a name that hasn't been resolved yet
+         (and (Type? t1) (subtype* A t1 t2)))))]
+  [(case: Name _)
+   (match* (t1 t2)
+     ;; Avoid resolving things that refer to different structs.
+     ;; Saves us from non-termination
+     [((NameStruct: s1) (or (? Struct? s2) (NameStruct: s2)))
+      #:when (unrelated-structs s1 s2)
+      #f]
+     [(_ _)
+      (let ([A (remember t1 t2 A)])
+        (with-updated-seen A
+          (let ([t1 (resolve-once t1)])
+            ;; check needed for if a name that hasn't been resolved yet
+            (and (Type? t1) (subtype* A t1 t2)))))])]
+  [(case: Pair (Pair: t11 t12))
+   (match t2
+     [(Pair: t21 t22)
+      (subtype-seq A
+                   (subtype* t11 t21)
+                   (subtype* t12 t22))]
+     [(Sequence: (list seq-t))
+      (subtype-seq A
+                   (subtype* t11 seq-t)
+                   (subtype* t12 (-lst seq-t)))]
+     [_ (continue A t1 t2)])]
+  [(case: Param (Param: in1 out1))
+   (match t2
+     [(Param: in2 out2) (subtype-seq A
+                                     (subtype* in2 in1)
+                                     (subtype* out1 out2))]
+     [_ (subtype* A (cl->* (t-> out1) (t-> in1 -Void)) t2)]
+     [_ (continue A t1 t2)])]
+  [(case: Poly (Poly: names b1))
+   (match t2
+     [(? Poly?) #:when (= (length names) (Poly-n t2))
+                (subtype* A b1 (Poly-body names t2))]
+     ;; use local inference to see if we can use the polytype here
+     [_ #:when (infer names null (list b1) (list t2) Univ) A]
+     [_ (continue A t1 t2)])]
+  [(case: PolyDots (PolyDots: (list ns ... n-dotted) b1))
+   (match t2
+     [(PolyDots: (list ms ... m-dotted) b2)
+      (cond
+        [(< (length ns) (length ms))
+         (define-values (short-ms rest-ms) (split-at ms (length ns)))
+         ;; substitute ms for ns in b1 to make it look like b2
+         (define subst
+           (hash-set (make-simple-substitution ns (map make-F short-ms))
+                     n-dotted (i-subst/dotted (map make-F rest-ms) (make-F m-dotted) m-dotted)))
+         (subtype* A (subst-all subst b1) b2)]
+        [else
+         (define-values (short-ns rest-ns) (split-at ns (length ms)))
+         ;; substitute ns for ms in b2 to make it look like b1
+         (define subst
+           (hash-set (make-simple-substitution ms (map make-F short-ns))
+                     m-dotted (i-subst/dotted (map make-F rest-ns) (make-F n-dotted) n-dotted)))
+         (subtype* A b1 (subst-all subst b2))])]
+     [(Poly: ms b2)
+      #:when (<= (length ns) (length ms))
+      ;; substitute ms for ns in b1 to make it look like b2
+      (define subst
+        (hash-set (make-simple-substitution ns (map make-F (take ms (length ns))))
+                  n-dotted (i-subst (map make-F (drop ms (length ns))))))
+      (subtype* A (subst-all subst b1) b2)]
+     [_ #:when (infer ns (list n-dotted) (list b1) (list t2) Univ)
+        A]
+     [_ (continue A t1 t2)])]
+  [(case: Prefab (Prefab: k1 ss))
+   (match t2
+     [(Prefab: k2 ts)
+      (let ([A (remember t1 t2 A)])
+        (with-updated-seen A
+          (and (prefab-key-subtype? k1 k2)
+               (and (>= (length ss) (length ts))
+                    (for/fold ([A A])
+                              ([s (in-list ss)]
+                               [t (in-list ts)]
+                               [mut? (in-list (prefab-key->field-mutability k2))]
+                               #:break (not A))
+                      (and A
+                           (if mut?
+                               (subtype-seq A
+                                            (subtype* t s)
+                                            (subtype* s t))
+                               (subtype* A s t))))))))]
+     [_ (continue A t1 t2)])]
+  [(case: Promise (Promise: elem1))
+   (match t2
+     [(Promise: elem2) (subtype* A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: Prompt-Tagof (Prompt-Tagof: body1 handler1))
+   (match t2
+     [(? Prompt-TagTop?) A]
+     [(Prompt-Tagof: body2 handler2)
+      (subtype-seq A
+                   (type-equiv? body1 body2)
+                   (type-equiv? handler1 handler2))]
+     [_ (continue A t1 t2)])]
+  [(case: Refinement (Refinement: t1-parent id1))
+   (match t2
+     [(Refinement: t2-parent id2)
+      #:when (free-identifier=? id1 id2)
+      (subtype* A t1-parent t2-parent)]
+     [_ (cond
+          [(subtype* A t1-parent t2)]
+          [else (continue A t1 t2)])])]
+  ;; sequences are covariant
+  [(case: Sequence (Sequence: ts1))
+   (match t2
+     [(Sequence: ts2) (subtypes* A ts1 ts2)]
+     [_ (continue A t1 t2)])]
+  [(case: Set (Set: elem1))
+   (match t2
+     [(Set: elem2) (subtype* A elem1 elem2)]
+     [(Sequence: (list seq-t)) (subtype* A elem1 seq-t)]
+     [_ (continue A t1 t2)])]
+  [(case: Struct (Struct: nm1 parent1 flds1 proc1 _ _))
+   (match t2
+     ;; Avoid resolving things that refer to different structs.
+     ;; Saves us from non-termination
+     [(or (? Struct? t2) (NameStruct: t2))
+      #:when (unrelated-structs t1 t2)
+      #f]
+     ;; subtyping on immutable structs is covariant
+     [(Struct: nm2 _ flds2 proc2 _ _)
+      #:when (free-identifier=? nm1 nm2)
+      (let ([A (remember t1 t2 A)])
+        (with-updated-seen A
+          (let ([A (cond [(and proc1 proc2) (subtype* A proc1 proc2)]
+                         [proc2 #f]
+                         [else A])])
+            (and A (subtype/flds* A flds1 flds2)))))]
+     [(StructTop: (Struct: nm2 _ _ _ _ _))
+      #:when (free-identifier=? nm1 nm2)
+      A]
+     [(Value: (? (negate struct?) _)) #f]
+     ;; subtyping on structs follows the declared hierarchy
+     [_ (cond
+          [(and (Type? parent1)
+                (let ([A (remember t1 t2 A)])
+                  (with-updated-seen A
+                    (subtype* A parent1 t2))))]
+          [else (continue A t1 t2)])]
+     [_ (continue A t1 t2)])]
+  [(case: StructType (StructType: t1*))
+   (match t2
+     [(StructTypeTop:) A]
+     [_ (continue A t1 t2)])]
+  [(case: Syntax (Syntax: elem1))
+   (match t2
+     [(Syntax: elem2) (subtype* A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: ThreadCell (ThreadCell: elem1))
+   (match t2
+     [(? ThreadCellTop?) A]
+     [(ThreadCell: elem2) (type-equiv? A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [(case: Union (Union: elems1))
+   (cond
+     [(cache-ref union-sub-cache t1 t2)
+      => (λ (b) (and (unbox b) A))]
+     [else
+      (define result
+        (match t2
+          [(Union: elems2)
+           (for/fold ([A A])
+                     ([elem1 (in-hset elems1)]
+                      #:break (not A))
+             (if (hset-member? elems2 elem1)
+                 A
+                 (subtype* A elem1 t2)))]
+          [_ (for/fold ([A A])
+                       ([elem1 (in-hset elems1)]
+                        #:break (not A))
+               (subtype* A elem1 t2))]))
+      (when (null? A)
+        (cache-set! union-sub-cache t1 t2 (and result #t)))
+      result])]
+  ;; For Unit types invoke-types are covariant
+  ;; imports and init-depends are covariant in that importing fewer
+  ;; signatures results in a subtype
+  ;; exports conversely are contravariant, subtypes export more signatures
+  [(case: Unit (Unit: imports1 exports1 init-depends1 t1*))
+   (match t2
+     [(? UnitTop?) A]
+     [(Unit: imports2 exports2 init-depends2 t2*)
+      (and (check-sub-signatures? imports2 imports1)
+           (check-sub-signatures? exports1 exports2)
+           (check-sub-signatures? init-depends2 init-depends1)
+           (subval* A t1* t2*))]
+     [_ (continue A t1 t2)])]
+  [(case: Value (Value: val1))
+   (match t2
+     [(Base: _ _ pred _) (and (pred val1) A)]
+     [(Sequence: (list seq-t))
+      (cond
+        [(null? val1) A]
+        [(exact-nonnegative-integer? val1)
+         (define possibilities
+           (list
+            (list byte? -Byte)
+            (list portable-index? -Index)
+            (list portable-fixnum? -NonNegFixnum)
+            (list values -Nat)))
+         (define type
+           (for/or ([pred-type (in-list possibilities)])
+             (match pred-type
+               [(list pred? type)
+                (and (pred? val1) type)])))
+         (subtype* A type seq-t)]
+        [else #f])]
+     [(or (? Struct? s1) (NameStruct: s1))
+      #:when (not (struct? val1))
+      #f]
+     [_ (continue A t1 t2)])]
+  [(case: Vector (Vector: elem1))
+   (match t2
+     [(? VectorTop?) A]
+     [(Vector: elem2) (type-equiv? A elem1 elem2)]
+     [(Sequence: (list seq-t)) (subtype* A elem1 seq-t)]
+     [_ (continue A t1 t2)])]
+  [(case: Weak-Box (Weak-Box: elem1))
+   (match t2
+     [(? Weak-BoxTop?) A]
+     [(Weak-Box: elem2) (type-equiv? A elem1 elem2)]
+     [_ (continue A t1 t2)])]
+  [else: (continue A t1 t2)])
diff --git a/typed-racket-lib/typed-racket/types/type-table.rkt b/typed-racket-lib/typed-racket/types/type-table.rkt
index 0b0e18d8..a117cf92 100644
--- a/typed-racket-lib/typed-racket/types/type-table.rkt
+++ b/typed-racket-lib/typed-racket/types/type-table.rkt
@@ -10,7 +10,7 @@
          "../utils/utils.rkt"
          (contract-req)
          (rep type-rep)
-         (types utils union printer)
+         (types utils printer)
          (typecheck possible-domains tc-metafunctions)
          (utils tc-utils)
          (for-template racket/base))
diff --git a/typed-racket-lib/typed-racket/types/union.rkt b/typed-racket-lib/typed-racket/types/union.rkt
index 59b5f8d5..d446b631 100644
--- a/typed-racket-lib/typed-racket/types/union.rkt
+++ b/typed-racket-lib/typed-racket/types/union.rkt
@@ -1,57 +1,55 @@
 #lang racket/base
 
 (require "../utils/utils.rkt"
+         (utils hset)
          (rep type-rep rep-utils)
          (prefix-in c: (contract-req))
          (types subtype base-abbrev resolve current-seen)
          racket/match
          racket/list)
 
+(provide normalize-type
+         Un
+         union)
 
-(provide/cond-contract
- [Un (() #:rest (c:listof Type?) . c:->* . Type?)])
+;; t1 ∪ t2
+;; But excludes duplicate info w.r.t. subtyping
+;; can be useful in a few places, but avoid using
+;; in hot code when Un (or similar) will suffice.
+(define (union t1 t2)
+  (cond
+    [(subtype t1 t2) t2]
+    [(subtype t2 t1) t1]
+    [else (Un t1 t2)]))
 
-;; a is a Type (not a union type)
-;; b is a List[Type] (non overlapping, non Union-types)
-;; The output is a non overlapping list of non Union types.
-;; The overlapping constraint is lifted if we are in the midst of subtyping. This is because during
-;; subtyping calls to subtype are expensive.
-(define (merge a b)
-  (define b* (make-Union b))
-  (match* (a b)
-    ;; If a union element is a Name application, then it should not
-    ;; be checked for subtyping since that can cause infinite
-    ;; loops if this is called during type instantiation.
-    [((App: (? Name? rator) rands stx) _)
-     ;; However, we should check if it's a well-formed application
-     ;; so that bad applications are rejected early.
-     (resolve-app-check-error rator rands stx)
-     (cons a b)]
-    [(_ _) #:when (currently-subtyping?) (cons a b)]
-    [((? (λ _ (subtype a b*))) _) b]
-    [((? (λ _ (subtype b* a))) _) (list a)]
-    [(_ _) (cons a (filter-not (λ (b-elem) (subtype b-elem a)) b))]))
+;; t is a Type (not a union type)
+;; b is a hset[Type] (non overlapping, non Union-types)
+;; The output is a non overlapping hset of non Union types.
+(define (merge t ts)
+  (let ([t (normalize-type t)])
+    (define t* (make-Union ts))
+    (cond
+      [(subtype t* t) (hset t)]
+      [(subtype t t*) ts]
+      [else (hset-add (hset-filter ts (λ (b-elem) (not (subtype b-elem t))))
+                      t)])))
 
-;; Type -> List[Type]
-(define (flat t)
+;; list[Type] -> hset[Type]
+(define (flatten ts)
+  (for/fold ([s (hset)])
+            ([t (in-hset ts)])
+    (match t
+      [(Union: ts) (hset-union s ts)]
+      [_ (hset-add s t)])))
+
+;; Recursively reduce unions so that they do not contain
+;; reduntant information w.r.t. subtyping. We used to maintain
+;; this properly throughout typechecking, but this was costly.
+;; Not we only do it as we are generating contracts, since we
+;; don't want to do redundant runtime checks, etc.
+(define (normalize-type t)
   (match t
-    [(Union: es) es]
-    [_ (list t)]))
-
-;; Union constructor
-;; Normalizes representation by sorting types.
-;; Type * -> Type
-;; The input types can overlap and be union types
-(define Un-cache (make-weak-hash))
-(define Un
-  (case-lambda 
-    [() -Bottom]
-    [(t) t]
-    [args 
-     (cond [(hash-ref Un-cache args #f)]
-           [else
-            (define ts (foldr merge '()
-                              (remove-duplicates (append-map flat args) type-equal?)))
-            (define type (make-Union ts))
-            (hash-set! Un-cache args type)
-            type])]))
+    [(Union: ts) (make-Union (for/fold ([ts (hset)])
+                                       ([t (in-hset (flatten ts))])
+                               (merge t ts)))]
+    [_ (Rep-fmap t normalize-type)]))
diff --git a/typed-racket-lib/typed-racket/types/update.rkt b/typed-racket-lib/typed-racket/types/update.rkt
index 9ad4ad80..c6148416 100644
--- a/typed-racket-lib/typed-racket/types/update.rkt
+++ b/typed-racket-lib/typed-racket/types/update.rkt
@@ -5,8 +5,8 @@
          (contract-req)
          (infer-in infer)
          (rep core-rep type-rep prop-rep object-rep values-rep rep-utils)
-         (utils tc-utils)
-         (types resolve subtype subtract union)
+         (utils tc-utils hset)
+         (types resolve subtype subtract)
          (rename-in (types abbrev)
                     [-> -->]
                     [->* -->*]
@@ -82,11 +82,11 @@
            (list (make-arr* doms (update rng rst))))]
          
          [((Union: ts) _)
-          (apply Un (map (λ (t) (update t path)) ts))]
+          (Union-map ts (λ (t) (update t path)))]
 
          [((Intersection: ts) _)
           (for/fold ([t Univ])
-                    ([elem (in-list ts)])
+                    ([elem (in-hset ts)])
             (intersect t (update elem path)))]
          
          [(_ _)
diff --git a/typed-racket-lib/typed-racket/utils/hset.rkt b/typed-racket-lib/typed-racket/utils/hset.rkt
new file mode 100644
index 00000000..129486a9
--- /dev/null
+++ b/typed-racket-lib/typed-racket/utils/hset.rkt
@@ -0,0 +1,169 @@
+#lang racket/base
+(require "utils.rkt"
+         (contract-req)
+         racket/match
+         (for-syntax racket/base racket/match))
+
+;; Lightweight variant of sets
+
+(provide hset hseteq hseteqv
+         hset?
+         hset-empty?
+         hset-member?
+         hset-count
+         hset-add
+         hset-remove
+         hset-first
+         hsubset?
+         hset-overlap?
+         hset=?
+         hset-subtract
+         hset-union
+         hset-intersect
+         hset-partition
+         hset-map
+         hset-filter
+         hset-for-each
+         hset->list
+         list->hset
+         list->hseteq
+         for/hset
+         for/hseteq
+         for/hseteqv
+         for*/hset
+         for*/hseteq
+         in-hset)
+
+(provide-for-cond-contract hsetof)
+
+(define-for-cond-contract (hsetof c) (hash/c c #t #:immutable #t #:flat? #t))
+
+(define build-hset
+  (case-lambda
+    [() #hash()]
+    [l (for/fold ([s #hash()]) ([e (in-list l)])
+         (hash-set s e #t))]))
+
+
+(define hset
+  (case-lambda
+    [() #hash()]
+    [l (for/fold ([s #hash()]) ([e (in-list l)])
+         (hash-set s e #t))]))
+
+(define hseteq
+  (case-lambda
+    [() #hasheq()]
+    [l (for/fold ([s #hasheq()]) ([e (in-list l)])
+         (hash-set s e #t))]))
+
+(define (hseteqv)
+  (case-lambda
+    [() #hasheqv()]
+    [l (for/fold ([s #hasheqv()]) ([e (in-list l)])
+         (hash-set s e #t))]))
+
+(define (hset? s) (hash? s))
+
+(define (hset-empty? s) (zero? (hash-count s)))
+(define (hset-member? s e) (hash-ref s e #f))
+(define (hset-count s) (hash-count s))
+
+(define (hset-add s e) (hash-set s e #t))
+(define (hset-remove s e) (hash-remove s e))
+(define (hset-first s) (hash-iterate-key s (hash-iterate-first s)))
+
+(define-syntax in-hset (make-rename-transformer #'in-immutable-hash-keys))
+
+(define (hsubset? s1 s2)
+  (hash-keys-subset? s1 s2))
+
+(define (hset-overlap? s1 s2)
+  (if ((hset-count s1) . < . (hset-count s2))
+      (hset-overlap? s2 s1)
+      (for/or ([k (in-hset s2)])
+        (hset-member? s1 k))))
+
+(define (hset=? s1 s2)
+  (or (eq? s1 s2)
+      (and (= (hash-count s1) (hash-count s2))
+           (hash-keys-subset? s1 s2))))
+
+(define (hset-subtract s1 s2)
+  (for/fold ([s1 s1]) ([k (in-hset s2)])
+    (hash-remove s1 k)))
+
+(define (hset-union s1 s2)
+  (if ((hset-count s1) . < . (hset-count s2))
+      (hset-union s2 s1)
+      (for/fold ([s1 s1]) ([k (in-hset s2)])
+        (hash-set s1 k #t))))
+
+(define (hset-intersect s1 s2)
+  (if ((hset-count s1) . < . (hset-count s2))
+      (hset-union s2 s1)
+      (for/fold ([s s2]) ([k (in-hset s2)])
+        (if (hash-ref s1 k #f)
+            s
+            (hash-remove s k)))))
+
+(define (hset-partition s pred empty-y-set empty-n-set)
+  (for/fold ([y empty-y-set] [n empty-n-set]) ([v (in-hset s)])
+    (if (pred v)
+        (values (hset-add y v) n)
+        (values y (hset-add n v)))))
+
+(define (hset->list s) (hash-keys s))
+
+(define (list->hset l)
+  (for/hset ([k (in-list l)])
+    k))
+
+(define (list->hseteq l)
+  (for/hseteq ([k (in-list l)])
+    k))
+
+(define (hset-map h f)
+  (for/fold ([result '()])
+            ([x (in-hset h)])
+    (cons (f x) result)))
+
+(define (hset-filter h f)
+  (for/fold ([result h])
+            ([x (in-hset h)])
+    (if (f x)
+        result
+        (hset-remove result x))))
+
+(define (hset-for-each h f)
+  (for ([x (in-hset h)]) (f x)))
+
+(define-syntax-rule (for/hset bindings body ...)
+  (for/hash bindings (values
+                      (let ()
+                        body ...)
+                      #t)))
+
+(define-syntax-rule (for/hseteq bindings body ...)
+  (for/hasheq bindings (values
+                        (let ()
+                          body ...)
+                        #t)))
+
+(define-syntax-rule (for/hseteqv bindings body ...)
+  (for/hasheqv bindings (values
+                         (let ()
+                           body ...)
+                         #t)))
+
+(define-syntax-rule (for*/hset bindings body ...)
+  (for*/hash bindings (values
+                       (let ()
+                         body ...)
+                       #t)))
+
+(define-syntax-rule (for*/hseteq bindings body ...)
+  (for*/hasheq bindings (values
+                         (let ()
+                           body ...)
+                         #t)))
diff --git a/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/typed-racket-lib/typed-racket/utils/tc-utils.rkt
index 9a91c70d..3f9feead 100644
--- a/typed-racket-lib/typed-racket/utils/tc-utils.rkt
+++ b/typed-racket-lib/typed-racket/utils/tc-utils.rkt
@@ -191,8 +191,9 @@ don't depend on any other portion of the system
 (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)
   (let ([stx (locate-stx stx*)])
     (unless (syntax? stx)
-      (int-err "erroneous syntax was not a syntax object: ~a ~a"
-               stx (syntax->datum stx*)))
+      (int-err "erroneous syntax was not a syntax object: ~a\n (error message: ~a)"
+               stx
+               msg))
     (current-type-error? #t)
     (if (delay-errors?)
         (set! delayed-errors (cons (make-err (apply format msg rest)
@@ -272,9 +273,10 @@ don't depend on any other portion of the system
           (string-append
            "Internal Typechecker Error: "
            (apply format msg args)
-           (format "\nwhile typechecking:\n~a\noriginally:\n~a"
-                   (syntax->datum (current-orig-stx))
-                   (syntax->datum (locate-stx (current-orig-stx)))))
+           (let ([stx (current-orig-stx)])
+             (format "\nwhile typechecking:\n~a\noriginally:\n~a"
+                     (and stx (syntax->datum stx))
+                     (and stx (syntax->datum (locate-stx stx))))))
           (current-continuation-marks))))
 
 ;; are we currently expanding in a typed module (or top-level form)?
diff --git a/typed-racket-lib/typed-racket/utils/utils.rkt b/typed-racket-lib/typed-racket/utils/utils.rkt
index 12cd22d1..29486a7d 100644
--- a/typed-racket-lib/typed-racket/utils/utils.rkt
+++ b/typed-racket-lib/typed-racket/utils/utils.rkt
@@ -22,6 +22,7 @@ at least theoretically.
  list-extend
  filter-multiple
  syntax-length
+ in-pair
  in-sequence-forever
  match*/no-order
  bind)
@@ -272,3 +273,12 @@ at least theoretically.
   (syntax-parser
     [(_ x:id val:expr)
      #'(app (λ (_) val) x)]))
+
+(define-syntax (assert stx)
+    (syntax-case stx ()
+      [(_ expr)
+       #`(unless expr #,(quasisyntax/loc stx (error 'assert "failed!")))]))
+
+
+(define-syntax-rule (in-pair p)
+  (in-parallel (in-value (car p)) (in-value (cdr p))))
diff --git a/typed-racket-more/typed/pict.rkt b/typed-racket-more/typed/pict.rkt
index 682cd4e9..0b741bbb 100644
--- a/typed-racket-more/typed/pict.rkt
+++ b/typed-racket-more/typed/pict.rkt
@@ -5,8 +5,7 @@
 (require pict
          "racket/private/gui-types.rkt"
          (for-syntax (only-in typed-racket/rep/type-rep
-                              make-Name
-                              make-Union)
+                              make-Name)
                      (submod "racket/private/gui-types.rkt" #%type-decl)))
 
 (begin-for-syntax
@@ -19,7 +18,7 @@
    (-inst (parse-type #'Color%)))
  (define -pict (-struct-name #'pict))
  (define -pict-path
-   (make-Union (list (-val #f) -pict (-lst -pict))))
+   (Un (-val #f) -pict (-lst -pict)))
  (define -child (-struct-name #'child))
  (define -text-style
    (-mu -text-style
diff --git a/typed-racket-more/typed/racket/async-channel.rkt b/typed-racket-more/typed/racket/async-channel.rkt
index 804c2692..17d30096 100644
--- a/typed-racket-more/typed/racket/async-channel.rkt
+++ b/typed-racket-more/typed/racket/async-channel.rkt
@@ -3,12 +3,12 @@
 ;; This module provides a typed version of racket/async-channel
 
 (require racket/async-channel
-         (for-syntax (only-in (rep type-rep) make-Async-ChannelTop)))
+         (for-syntax (only-in (rep type-rep) -Async-ChannelTop)))
 
 ;; Section 11.2.4 (Buffered Asynchronous Channels)
 (type-environment
  [make-async-channel (-poly (a) (->opt [(-opt -PosInt)] (-async-channel a)))]
- [async-channel? (make-pred-ty (make-Async-ChannelTop))]
+ [async-channel? (make-pred-ty -Async-ChannelTop)]
  [async-channel-get (-poly (a) ((-async-channel a) . -> . a))]
  [async-channel-try-get (-poly (a) ((-async-channel a) . -> . (-opt a)))]
  [async-channel-put (-poly (a) ((-async-channel a) a . -> . -Void))]
diff --git a/typed-racket-more/typed/rackunit/type-env-ext.rkt b/typed-racket-more/typed/rackunit/type-env-ext.rkt
index 597a5fe7..5434639c 100644
--- a/typed-racket-more/typed/rackunit/type-env-ext.rkt
+++ b/typed-racket-more/typed/rackunit/type-env-ext.rkt
@@ -7,7 +7,7 @@
           (utils tc-utils)
           (env init-envs)
           (except-in (rep prop-rep object-rep type-rep) make-arr)
-          (rename-in (types abbrev union) [make-arr* make-arr])))
+          (rename-in (types abbrev) [make-arr* make-arr])))
 
 (define-for-syntax unit-env
   (make-env
diff --git a/typed-racket-test/fail/issue-169-1.rkt b/typed-racket-test/fail/issue-169-1.rkt
index 5f6eaa7c..125886d9 100644
--- a/typed-racket-test/fail/issue-169-1.rkt
+++ b/typed-racket-test/fail/issue-169-1.rkt
@@ -1,5 +1,5 @@
 #;
-(exn-pred #rx"expected: \\(Listof Nothing\\).*given: \\(Listof Pos\\*\\)")
+(exn-pred #rx"expected: \\Null.*given: \\(Listof Pos\\*\\)")
 #lang typed/racket
 (define-type Pos Integer)
 (define-new-subtype Pos* (p Pos))
diff --git a/typed-racket-test/fail/issue-169-2.rkt b/typed-racket-test/fail/issue-169-2.rkt
index fbb99eb0..e38bd54f 100644
--- a/typed-racket-test/fail/issue-169-2.rkt
+++ b/typed-racket-test/fail/issue-169-2.rkt
@@ -1,5 +1,5 @@
 #;
-(exn-pred #rx"expected: \\(Listof Nothing\\).*given: \\(Listof Pos\\*\\)")
+(exn-pred #rx"expected: \\Null.*given: \\(Listof Pos\\*\\)")
 #lang typed/racket
 (define-type Pos Integer)
 (define-new-subtype Pos* (p Pos))
diff --git a/typed-racket-test/performance/infer-timing.rkt b/typed-racket-test/performance/infer-timing.rkt
index ea40d153..72e09b02 100644
--- a/typed-racket-test/performance/infer-timing.rkt
+++ b/typed-racket-test/performance/infer-timing.rkt
@@ -1,7 +1,6 @@
 #lang racket
 
 (require typed-racket/infer/infer
-         typed-racket/types/union
          typed-racket/types/prop-ops
          typed-racket/types/abbrev
          typed-racket/rep/type-rep
diff --git a/typed-racket-test/unit-tests/check-below-tests.rkt b/typed-racket-test/unit-tests/check-below-tests.rkt
index b2245ae7..27e96688 100644
--- a/typed-racket-test/unit-tests/check-below-tests.rkt
+++ b/typed-racket-test/unit-tests/check-below-tests.rkt
@@ -3,7 +3,7 @@
 (require "test-utils.rkt"
          rackunit racket/list racket/match racket/format
          syntax/srcloc syntax/location
-         (types abbrev union tc-result)
+         (types abbrev tc-result)
          (utils tc-utils)
          (rep prop-rep object-rep type-rep)
          (typecheck check-below)
diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt
index 2b0a9254..afaf12ea 100644
--- a/typed-racket-test/unit-tests/class-tests.rkt
+++ b/typed-racket-test/unit-tests/class-tests.rkt
@@ -25,7 +25,7 @@
                     define lambda λ case-lambda)
          (prefix-in tr: (only-in (base-env prims) define lambda λ case-lambda))
          (for-syntax (rep type-rep prop-rep object-rep)
-                     (rename-in (types abbrev union numeric-tower prop-ops utils)
+                     (rename-in (types abbrev numeric-tower prop-ops utils)
                                 [Un t:Un]
                                 [-> t:->])))
 
@@ -1485,7 +1485,7 @@
                           (init-rest [rst : (List Symbol)])))
              (make-object c% "wrong"))
            #:ret (tc-ret (make-Instance (make-Class #f null null null null (-Tuple (list -Symbol)))))
-           #:msg #rx"expected: \\(List Symbol.*given: \\(List String"]
+           #:msg #rx"expected: Symbol.*given: String"]
    ;; PR 14408, test init-field order
    [tc-e (let ()
            (define c%
diff --git a/typed-racket-test/unit-tests/contract-tests.rkt b/typed-racket-test/unit-tests/contract-tests.rkt
index 6a13a605..4b6ac760 100644
--- a/typed-racket-test/unit-tests/contract-tests.rkt
+++ b/typed-racket-test/unit-tests/contract-tests.rkt
@@ -6,7 +6,7 @@
          (for-template racket/base)
          (private type-contract)
          (rep type-rep values-rep)
-         (types abbrev numeric-tower union)
+         (types abbrev numeric-tower)
          (static-contracts combinators optimize)
          (submod typed-racket/private/type-contract numeric-contracts)
          (submod typed-racket/private/type-contract test-exports)
@@ -20,7 +20,7 @@
 
 (define-syntax-rule (t e)
   (test-case (format "~a" 'e)
-    (let ((v e))
+    (let ([v e])
       (with-check-info (('type v))
         (type->contract
           e
@@ -128,262 +128,263 @@
                       (fun-val ctced-val))))))]))
 
 (define tests
-  (test-suite "Contract Tests"
-              (t (-Number . -> . -Number))
-              (t (-Promise -Number))
-              (t (-set Univ)) 
-              (t (make-pred-ty -Symbol))
-              (t (->key -Symbol #:key -Boolean #t Univ))
-              (t (make-Function
-                   (list (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key Univ #t))
-                                    #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol))))))
-              (t (-struct #'struct-name1 #f (list (make-fld -Symbol #'acc #f))))
-              ;; Adapted from PR 13815
-              (t (-poly (a) (-> a a)))
-              (t (-poly (a) (-mu X (-> a X))))
-              (t (-poly (a) (-poly (b) (-> a a))))
-              (t (-poly (a) (-App (-poly (b) (-> a a)) (list -Number) #'#f)))
+  (test-suite
+   "Contract Tests"
+   (t (-Number . -> . -Number))
+   (t (-Promise -Number))
+   (t (-set Univ)) 
+   (t (make-pred-ty -Symbol))
+   (t (->key -Symbol #:key -Boolean #t Univ))
+   (t (make-Function
+       (list (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key Univ #t))
+                        #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol))))))
+   (t (-struct #'struct-name1 #f (list (make-fld -Symbol #'acc #f))))
+   ;; Adapted from PR 13815
+   (t (-poly (a) (-> a a)))
+   (t (-poly (a) (-mu X (-> a X))))
+   (t (-poly (a) (-poly (b) (-> a a))))
+   (t (-poly (a) (-App (-poly (b) (-> a a)) (list -Number))))
 
-              (t (-poly (a) -Flonum))
-              (t (-poly (a) (-set -Number)))
-              (t (-poly (a) (-lst a)))
-              (t (-poly (a) (-vec a)))
-              (t (-> (-poly (A B) (-> (Un A (-mu X (Un A (-lst X)))) (Un A (-mu X (Un A (-lst X))))))
-                     (-> -Symbol (-mu X (Un -Symbol (-lst X))))))
+   (t (-poly (a) -Flonum))
+   (t (-poly (a) (-set -Number)))
+   (t (-poly (a) (-lst a)))
+   (t (-poly (a) (-vec a)))
+   (t (-> (-poly (A B) (-> (Un A (-mu X (Un A (-lst X)))) (Un A (-mu X (Un A (-lst X))))))
+          (-> -Symbol (-mu X (Un -Symbol (-lst X))))))
 
-              (t (-polydots (a) -Symbol))
-              (t (-polydots (a) (->... (list) (a a) -Symbol)))
+   (t (-polydots (a) -Symbol))
+   (t (-polydots (a) (->... (list) (a a) -Symbol)))
 
-              (t (-polyrow (a) (list null null null null) -Symbol))
-              (t (-polyrow (a) (list null null null null)
-                   (-> (-class #:row (-v a)) (-class #:row (-v a)))))
+   (t (-polyrow (a) (list null null null null) -Symbol))
+   (t (-polyrow (a) (list null null null null)
+                (-> (-class #:row (-v a)) (-class #:row (-v a)))))
 
-              (t (-mu x (-Syntax x)))
-              (t (-> (-> Univ -Bottom : -ff-propset) -Bottom : -ff-propset))
-              (t (-poly (A B) (-> A B (Un A B))))
+   (t (-mu x (-Syntax x)))
+   (t (-> (-> Univ -Bottom : -ff-propset) -Bottom : -ff-propset))
+   (t (-poly (A B) (-> A B (Un A B))))
 
 
-              (t/fail ((-poly (a) (-vec a)) . -> . -Symbol)
-                      "cannot generate contract for non-function polymorphic type")
-              (t/fail (-> (-poly (a b) (-> (Un a b) (Un a b))) Univ)
-                      "multiple parametric contracts are not supported")
-              (t/fail
-                (-> (-poly (A B) (-> (Un B (-mu X (Un A (-lst X)))) (Un B (-mu X (Un A (-lst X))))))
-                    (-> -Symbol (-mu X (Un -Symbol (-lst X)))))
-                "multiple parametric contracts are not supported")
-              (t/fail (-> (-polydots (a) (->... (list) (a a) -Symbol)) Univ)
-                      "cannot generate contract for variable arity polymorphic type")
+   (t/fail ((-poly (a) (-vec a)) . -> . -Symbol)
+           "cannot generate contract for non-function polymorphic type")
+   (t/fail (-> (-poly (a b) (-> (Un a b) (Un a b))) Univ)
+           "multiple parametric contracts are not supported")
+   (t/fail
+    (-> (-poly (A B) (-> (Un B (-mu X (Un A (-lst X)))) (Un B (-mu X (Un A (-lst X))))))
+        (-> -Symbol (-mu X (Un -Symbol (-lst X)))))
+    "multiple parametric contracts are not supported")
+   (t/fail (-> (-polydots (a) (->... (list) (a a) -Symbol)) Univ)
+           "cannot generate contract for variable arity polymorphic type")
 
-              ;; PR 14894 - FIXME: the polydots case may be possible for typed functions
-              (t/fail (-polydots (a) (->... (list) (a a) (make-ValuesDots null a 'a)))
-                      "dotted return values")
-              (t/fail (-> ManyUniv)
-                      "unknown return values")
+   ;; PR 14894 - FIXME: the polydots case may be possible for typed functions
+   (t/fail (-polydots (a) (->... (list) (a a) (make-ValuesDots null a 'a)))
+           "dotted return values")
+   (t/fail (-> ManyUniv)
+           "unknown return values")
 
-              ;; Github Issue #50
-              (t (cl->* (-> -String -Bottom) (-> -String -Symbol -Bottom)))
-              (t (make-Function
-                  (list (make-arr* (list -String) -Boolean
-                                   #:kws (list (make-Keyword '#:key Univ #t))
-                                   #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
-                        (make-arr* (list -String Univ) -Boolean
-                                   #:kws (list (make-Keyword '#:key Univ #t))
-                                   #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol))))))
-              (t/fail (cl->* (-> -String ManyUniv) (-> -String Univ ManyUniv))
-                      "unknown return values")
+   ;; Github Issue #50
+   (t (cl->* (-> -String -Bottom) (-> -String -Symbol -Bottom)))
+   (t (make-Function
+       (list (make-arr* (list -String) -Boolean
+                        #:kws (list (make-Keyword '#:key Univ #t))
+                        #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
+             (make-arr* (list -String Univ) -Boolean
+                        #:kws (list (make-Keyword '#:key Univ #t))
+                        #:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol))))))
+   (t/fail (cl->* (-> -String ManyUniv) (-> -String Univ ManyUniv))
+           "unknown return values")
 
-              (t/fail
-                (make-Function
-                  (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
-                    (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #f)))))
-                "case function type with optional keyword arguments")
-              (t/fail (-> (make-pred-ty -Symbol)-Symbol)
-                      "function type with props or objects")
-              (t/fail (cl->*
-                        (-> -Boolean -Boolean)
-                        (-> -Symbol -Symbol))
-                      "two cases of arity 1")
-              (t/fail (-struct #'struct-name2 #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
-                      "procedural structs are not supported")
-              (t/fail (-Syntax (-> -Boolean -Boolean))
-                      "required a flat contract but generated a chaperone contract")
-              (t/fail (-Syntax (-seq -Boolean))
-                      "required a flat contract but generated an impersonator contract")
-              (t/fail (-set (-seq -Boolean))
-                      "required a chaperone contract but generated an impersonator contract")
+   (t/fail
+    (make-Function
+     (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
+           (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #f)))))
+    "case function type with optional keyword arguments")
+   (t/fail (-> (make-pred-ty -Symbol)-Symbol)
+           "function type with props or objects")
+   (t/fail (cl->*
+            (-> -Boolean -Boolean)
+            (-> -Symbol -Symbol))
+           "two cases of arity 1")
+   (t/fail (-struct #'struct-name2 #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
+           "procedural structs are not supported")
+   (t/fail (-Syntax (-> -Boolean -Boolean))
+           "required a flat contract but generated a chaperone contract")
+   (t/fail (-Syntax (-seq -Boolean))
+           "required a flat contract but generated an impersonator contract")
+   (t/fail (-set (-seq -Boolean))
+           "required a chaperone contract but generated an impersonator contract")
 
-              (t/fail
-                (make-Function
-                  (list
-                    (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
-                    (make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t)))))
-                "case function type with optional keyword arguments")
-              (t/fail (-vec (-struct #'struct-name3 #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t))
-                      "required a chaperone contract but generated an impersonator contract")
+   (t/fail
+    (make-Function
+     (list
+      (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
+      (make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t)))))
+    "case function type with optional keyword arguments")
+   (t/fail (-vec (-struct #'struct-name3 #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t))
+           "required a chaperone contract but generated an impersonator contract")
 
-              (t-sc -Number number/sc)
-              (t-sc -Integer integer/sc)
-              (t-sc (-lst Univ) (listof/sc any-wrap/sc))
-              (t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
+   (t-sc -Number number/sc)
+   (t-sc -Integer integer/sc)
+   (t-sc (-lst Univ) (listof/sc any-wrap/sc))
+   (t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
 
-              ;; Github pull request #226
-              (let ([ctc (-> Univ -Boolean)])
-                ;; Ordinary functions should have a contract
-                (t-int ctc
-                       (lambda (f) (f 6))
-                       (lambda (x) #t)
-                       #:untyped)
-                (t-int/fail ctc
-                            (lambda (f) (f 6))
-                            (lambda (x) 'bad)
-                            #:untyped
-                            #:msg #rx"promised: boolean\\?.*produced: 'bad.*blaming: untyped")
-                ;; Struct predicates should not have a contract
-                (t-int ctc
-                       (lambda (foo?)
-                         (when (has-contract? foo?)
-                           (error "Regression failed for PR #266: struct predicate has a contract"))
-                         (foo? foo?))
-                       (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
-                         foo?)
-                       #:untyped)
-                ;; Unless the struct predicate is guarded by an untyped chaperone
-                (t-int/fail ctc
-                            (lambda (foo?) (foo? string-append))
-                            (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
-                              (chaperone-procedure foo? (lambda (x) (x 0) x)))
-                            #:untyped
-                            #:msg #rx"broke its own contract")
-                ;; Typed chaperones are okay, though
-                (t-int ctc
-                       (lambda (foo?)
-                         (when (has-contract? foo?)
-                           (error "Regression failed for PR #266: typed chaperone has a contract"))
-                         (foo? foo?))
-                       (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
-                         (chaperone-procedure foo? #f))
-                       #:typed))
+   ;; Github pull request #226
+   (let ([ctc (-> Univ -Boolean)])
+     ;; Ordinary functions should have a contract
+     (t-int ctc
+            (lambda (f) (f 6))
+            (lambda (x) #t)
+            #:untyped)
+     (t-int/fail ctc
+                 (lambda (f) (f 6))
+                 (lambda (x) 'bad)
+                 #:untyped
+                 #:msg #rx"promised: boolean\\?.*produced: 'bad.*blaming: untyped")
+     ;; Struct predicates should not have a contract
+     (t-int ctc
+            (lambda (foo?)
+              (when (has-contract? foo?)
+                (error "Regression failed for PR #266: struct predicate has a contract"))
+              (foo? foo?))
+            (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+              foo?)
+            #:untyped)
+     ;; Unless the struct predicate is guarded by an untyped chaperone
+     (t-int/fail ctc
+                 (lambda (foo?) (foo? string-append))
+                 (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+                   (chaperone-procedure foo? (lambda (x) (x 0) x)))
+                 #:untyped
+                 #:msg #rx"broke its own contract")
+     ;; Typed chaperones are okay, though
+     (t-int ctc
+            (lambda (foo?)
+              (when (has-contract? foo?)
+                (error "Regression failed for PR #266: typed chaperone has a contract"))
+              (foo? foo?))
+            (let-values ([(_t _c foo? _a _m) (make-struct-type 'foo #f 0 0)])
+              (chaperone-procedure foo? #f))
+            #:typed))
 
-              ;; classes
-              (t-sc (-class) (class/sc #f null null))
-              (t-sc (-class #:init ([x -Number #f] [y -Number #f]))
-                    (class/sc #f
-                              (list (member-spec 'init 'x number/sc)
-                                    (member-spec 'init 'y number/sc))
-                              null))
-              (t-sc (-class #:init ([x -Number #f] [y -Number #t]))
-                    (class/sc #f
-                              (list (member-spec 'init 'x number/sc)
-                                    (member-spec 'init 'y number/sc))
-                              null))
-              (t-sc (-class #:init ([x -Number #f]) #:init-field ([y -Integer #f]))
-                    (class/sc #f
-                              (list (member-spec 'init 'x number/sc)
-                                    (member-spec 'init 'y integer/sc)
-                                    (member-spec 'field 'y integer/sc))
-                              null))
-              (t (-class #:method ([m (-poly (x) (-> x x))])))
-              (t (-class #:method ([m (-polydots (x) (->... (list) (x x) -Void))])))
-              (t (-class #:method ([m (-polyrow (x) (list null null null null)
-                                        (-> (-class #:row (-v x)) -Void))])))
+   ;; classes
+   (t-sc (-class) (class/sc #f null null))
+   (t-sc (-class #:init ([x -Number #f] [y -Number #f]))
+         (class/sc #f
+                   (list (member-spec 'init 'x number/sc)
+                         (member-spec 'init 'y number/sc))
+                   null))
+   (t-sc (-class #:init ([x -Number #f] [y -Number #t]))
+         (class/sc #f
+                   (list (member-spec 'init 'x number/sc)
+                         (member-spec 'init 'y number/sc))
+                   null))
+   (t-sc (-class #:init ([x -Number #f]) #:init-field ([y -Integer #f]))
+         (class/sc #f
+                   (list (member-spec 'init 'x number/sc)
+                         (member-spec 'init 'y integer/sc)
+                         (member-spec 'field 'y integer/sc))
+                   null))
+   (t (-class #:method ([m (-poly (x) (-> x x))])))
+   (t (-class #:method ([m (-polydots (x) (->... (list) (x x) -Void))])))
+   (t (-class #:method ([m (-polyrow (x) (list null null null null)
+                                     (-> (-class #:row (-v x)) -Void))])))
               
-              ;; units
-              ;; These tests do not have sufficient coverage because more
-              ;; coverage requires a proper set up of the signature environment.
-              ;; Further coverage of unit contract compilations occurs in
-              ;; integration tests.
-              (t-sc (-unit null null null (-values (list -Integer)))
-                    (unit/sc null null null (list integer/sc)))
-              (t-sc (-unit null null null (-values (list -Integer -Number)))
-                    (unit/sc null null null (list integer/sc number/sc)))
-              (t-sc (-unit null null null (-values (list)))
-                    (unit/sc null null null null))
+   ;; units
+   ;; These tests do not have sufficient coverage because more
+   ;; coverage requires a proper set up of the signature environment.
+   ;; Further coverage of unit contract compilations occurs in
+   ;; integration tests.
+   (t-sc (-unit null null null (-values (list -Integer)))
+         (unit/sc null null null (list integer/sc)))
+   (t-sc (-unit null null null (-values (list -Integer -Number)))
+         (unit/sc null null null (list integer/sc number/sc)))
+   (t-sc (-unit null null null (-values (list)))
+         (unit/sc null null null null))
                             
-              ;; typed/untyped interaction tests
-              (t-int (-poly (a) (-> a a))
-                     (λ (f) (f 1))
-                     (λ (x) 1)
-                     #:typed)
-              (t-int/fail (-poly (a) (-> a a))
-                          (λ (f) (f 1))
-                          (λ (x) 1)
-                          #:untyped
-                          #:msg #rx"produced: 1.*blaming: untyped")
-              (t-int (cl->* (->* '() -String -String)
-                            (->* (list -Symbol) -Symbol -Symbol))
-                     (λ (f) (f "a" "b"))
-                     (case-lambda [xs (car xs)]
-                                  [(sym . xs) sym]))
-              (t-int (make-Evt -String)
-                     (λ (x) (channel-get x))
-                     (let ([ch (make-channel)])
-                       (thread (λ () (channel-put ch "ok")))
-                       ch)
-                     #:untyped)
-              (t-int/fail (make-Evt -String)
-                          (λ (x) (channel-get x))
-                          (let ([ch (make-channel)])
-                            (thread (λ () (channel-put ch 'bad)))
-                            ch)
-                          #:untyped
-                          #:msg #rx"promised: String.*produced: 'bad")
-              (t-int/fail (make-Evt (-> -String -String))
-                          (λ (x) ((sync x) 'bad))
-                          (let ([ch (make-channel)])
-                            (thread
-                             (λ ()
-                               (channel-put ch (λ (x) (string-append x "x")))))
-                            ch)
-                          #:typed
-                          #:msg #rx"expected: String.*given: 'bad")
-              (t-int/fail (make-Evt -String)
-                          (λ (x) (channel-put x "bad"))
-                          (make-channel)
-                          #:untyped
-                          #:msg #rx"cannot put on a channel")
-              ;; typed/untyped interaction with class/object contracts
-              (t-int/fail (-object #:method ([m (-> -String)]))
-                          (λ (o) (send o n))
-                          (new (class object% (super-new)
-                                 (define/public (m) "m")
-                                 (define/public (n) "n")))
-                          #:typed
-                          #:msg #rx"cannot call uncontracted")
-              (t-int (-class #:method ([m (-> -String)]))
-                     (λ (s%) (class s% (super-new)
-                               (define/public (n) "ok")))
-                     (class object% (super-new)
-                       (define/public (m) "m"))
-                     #:untyped)
+   ;; typed/untyped interaction tests
+   (t-int (-poly (a) (-> a a))
+          (λ (f) (f 1))
+          (λ (x) 1)
+          #:typed)
+   (t-int/fail (-poly (a) (-> a a))
+               (λ (f) (f 1))
+               (λ (x) 1)
+               #:untyped
+               #:msg #rx"produced: 1.*blaming: untyped")
+   (t-int (cl->* (->* '() -String -String)
+                 (->* (list -Symbol) -Symbol -Symbol))
+          (λ (f) (f "a" "b"))
+          (case-lambda [xs (car xs)]
+                       [(sym . xs) sym]))
+   (t-int (make-Evt -String)
+          (λ (x) (channel-get x))
+          (let ([ch (make-channel)])
+            (thread (λ () (channel-put ch "ok")))
+            ch)
+          #:untyped)
+   (t-int/fail (make-Evt -String)
+               (λ (x) (channel-get x))
+               (let ([ch (make-channel)])
+                 (thread (λ () (channel-put ch 'bad)))
+                 ch)
+               #:untyped
+               #:msg #rx"promised: String.*produced: 'bad")
+   (t-int/fail (make-Evt (-> -String -String))
+               (λ (x) ((sync x) 'bad))
+               (let ([ch (make-channel)])
+                 (thread
+                  (λ ()
+                    (channel-put ch (λ (x) (string-append x "x")))))
+                 ch)
+               #:typed
+               #:msg #rx"expected: String.*given: 'bad")
+   (t-int/fail (make-Evt -String)
+               (λ (x) (channel-put x "bad"))
+               (make-channel)
+               #:untyped
+               #:msg #rx"cannot put on a channel")
+   ;; typed/untyped interaction with class/object contracts
+   (t-int/fail (-object #:method ([m (-> -String)]))
+               (λ (o) (send o n))
+               (new (class object% (super-new)
+                      (define/public (m) "m")
+                      (define/public (n) "n")))
+               #:typed
+               #:msg #rx"cannot call uncontracted")
+   (t-int (-class #:method ([m (-> -String)]))
+          (λ (s%) (class s% (super-new)
+                    (define/public (n) "ok")))
+          (class object% (super-new)
+            (define/public (m) "m"))
+          #:untyped)
 
-              ;; Github issue #368
-              (t-int/fail (-> -Integer -Integer)
-                          values
-                          3
-                          #:untyped
-                          #:msg #rx"promised: a procedure")
-              (t-int/fail (-> -Integer -Integer)
-                          values
-                          (λ () 3)
-                          #:untyped
-                          #:msg #rx"that accepts 1 non-keyword")
+   ;; Github issue #368
+   (t-int/fail (-> -Integer -Integer)
+               values
+               3
+               #:untyped
+               #:msg #rx"promised: a procedure")
+   (t-int/fail (-> -Integer -Integer)
+               values
+               (λ () 3)
+               #:untyped
+               #:msg #rx"that accepts 1 non-keyword")
 
-              ;; Value types with numbers shouldn't be checked with =
-              (t-int/fail (make-Value 3.0)
-                          values
-                          3
-                          #:untyped
-                          #:msg #rx"promised: 3.0")
-              (t-int/fail (make-Value 3)
-                          values
-                          3.0
-                          #:untyped
-                          #:msg #rx"promised: 3")
+   ;; Value types with numbers shouldn't be checked with =
+   (t-int/fail (make-Value 3.0)
+               values
+               3
+               #:untyped
+               #:msg #rx"promised: 3.0")
+   (t-int/fail (make-Value 3)
+               values
+               3.0
+               #:untyped
+               #:msg #rx"promised: 3")
 
-              ;; intersection types
-              (t (-unsafe-intersect (-seq -Symbol) (-pair -Symbol (-lst -Symbol))))
-              (t/fail (-unsafe-intersect (-Number . -> . -Number) (-String . -> . -String))
-                      "more than 1 non-flat contract")
-              (t/fail (-unsafe-intersect (-box -Symbol) (-box Univ))
-                      "more than 1 non-flat contract")
-              ))
+   ;; intersection types
+   (t (-unsafe-intersect (-seq -Symbol) (-pair -Symbol (-lst -Symbol))))
+   (t/fail (-unsafe-intersect (-Number . -> . -Number) (-String . -> . -String))
+           "more than 1 non-flat contract")
+   (t/fail (-unsafe-intersect (-box -Symbol) (-box Univ))
+           "more than 1 non-flat contract")
+   ))
diff --git a/typed-racket-test/unit-tests/generalize-tests.rkt b/typed-racket-test/unit-tests/generalize-tests.rkt
index cdbba86f..13596e54 100644
--- a/typed-racket-test/unit-tests/generalize-tests.rkt
+++ b/typed-racket-test/unit-tests/generalize-tests.rkt
@@ -4,7 +4,7 @@
          racket/format
          rackunit
          (rep rep-utils core-rep type-rep)
-         (types generalize abbrev union)
+         (types generalize abbrev)
          (for-syntax racket/base syntax/parse))
 
 (provide tests)
@@ -18,7 +18,7 @@
          (define expected exp*)
          (with-check-info (['actual actual]
                            ['expected expected])
-           (unless (type-equal? actual expected)
+           (unless (equal? actual expected)
              (fail-check "Didn't generalize to expected type."))))]))
 
 
diff --git a/typed-racket-test/unit-tests/infer-tests.rkt b/typed-racket-test/unit-tests/infer-tests.rkt
index 660528b8..3a23f777 100644
--- a/typed-racket-test/unit-tests/infer-tests.rkt
+++ b/typed-racket-test/unit-tests/infer-tests.rkt
@@ -5,20 +5,14 @@
   racket/list
   (for-syntax racket/base syntax/parse)
   syntax/location syntax/srcloc
-  (rep type-rep)
+  (rep rep-utils type-rep free-variance values-rep)
   (r:infer infer promote-demote)
 
-  (types union substitute numeric-tower utils abbrev))
+  (types substitute numeric-tower utils abbrev))
 
 (provide tests)
 (gen-test-main)
 
-(define-syntax-rule (fv-t ty elems ...)
-  (let ([ty* ty])
-    (test-check (format "~a" 'ty)
-                equal?
-                (fv ty*)
-                (list (quote elems) ...))))
 
 (begin-for-syntax
   (define-splicing-syntax-class result
@@ -35,6 +29,109 @@
     (pattern #:pass #:with pass #'#t)
     (pattern #:fail #:with pass #'#f)))
 
+
+(define N -Number)
+(define B -Boolean)
+
+(define-syntax-rule (fv-t ty [elems variances] ...)
+  (let ([ty* ty])
+    (test-check
+     (format "~a" 'ty)
+     equal?
+     (free-vars-hash (free-vars* ty*))
+     (make-immutable-hasheq (list (cons (quote elems) variances) ...)))))
+
+(define-syntax-rule (fi-t ty [elems variances] ...)
+  (let ([ty* ty])
+    (test-check
+     (format "~a" 'ty)
+     equal?
+     (free-vars-hash (free-idxs* ty*))
+     (make-immutable-hasheq (list (cons (quote elems) variances) ...)))))
+
+(define fv-tests
+  (test-suite
+   "Tests for fv"
+   [fv-t N]
+   [fv-t (-v a) [a variance:co]]
+   [fv-t (-pair (-v a) (-v b)) [a variance:co] [b variance:co]]
+   [fv-t (-pair (-HT (-v a) (-v b)) (-v c)) [a variance:inv] [b variance:inv] [c variance:co]]
+   [fv-t (-poly (a) a)]
+   [fv-t (-poly (a) (-v b)) [b variance:co]]
+   [fv-t (-poly (a b c d e) a)]
+   [fv-t (-poly (b) (-v a)) [a variance:co]]
+   [fv-t (-poly (b c d e) (-v a)) [a variance:co]]
+   [fv-t (-mu a (-lst a))]
+   [fv-t (-mu a (-lst (-pair a (-v b)))) [b variance:co]]
+   [fv-t (-vec (-lst (-v a))) [a variance:inv]]
+   [fv-t (->* null (-v a) N) [a variance:contra]]
+   ))
+
+(define fi-tests
+  (test-suite
+   "Test suite for fi"
+   [fi-t (make-ValuesDots null (-v a) 'a) [a variance:co]]
+   [fi-t (->... (list) ((-v a) (-v a)) (make-ValuesDots null (-v a) 'a))
+         [a variance:co]]))
+
+(define-syntax (pd-t stx)
+  (syntax-parse stx
+    ([_ S:expr (vars:id ...) D:expr P:expr]
+     (quasisyntax/loc stx
+       (test-case (format "~a => ~a < ~a < ~a" '(vars ...) 'D 'S 'P)
+         (define S-v S)
+         (define promoted (var-promote S-v '(vars ...)))
+         (define demoted (var-demote S-v '(vars ...)))
+         #,(syntax/loc stx
+             (check-equal? promoted P "Promoted value doesn't match expected."))
+         #,(syntax/loc stx
+             (check-equal? demoted D "Demoted value doesn't match expected.")))))))
+
+(define pd-tests
+  (test-suite
+   "Tests for var-promote/var-demote"
+   (pd-t Univ () Univ Univ)
+   (pd-t (-v a) () (-v a) (-v a))
+   (pd-t (-v a) (a) -Bottom Univ)
+   (pd-t (-v a) (b) (-v a) (-v a))
+   (pd-t (-vec (-v a)) (a) (-vec -Bottom) (-vec Univ))
+   (pd-t (-vec (-lst (-v a))) (a) (-vec -Bottom) (-vec Univ))
+   (pd-t (-vec (-v a)) (b) (-vec (-v a)) (-vec (-v a)))
+
+   (pd-t (-box (-v a)) (a) (-box -Bottom) (-box Univ))
+   (pd-t (-box (-lst (-v a))) (a) (-box -Bottom) (-box Univ))
+   (pd-t (-box (-v a)) (b) (-box (-v a)) (-box (-v a)))
+
+   (pd-t (-channel (-v a)) (a) (-channel -Bottom) (-channel Univ))
+   (pd-t (-channel (-lst (-v a))) (a) (-channel -Bottom) (-channel Univ))
+   (pd-t (-channel (-v a)) (b) (-channel (-v a)) (-channel (-v a)))
+
+   (pd-t (-thread-cell (-v a)) (a) (-thread-cell -Bottom) (-thread-cell Univ))
+   (pd-t (-thread-cell (-lst (-v a))) (a) (-thread-cell -Bottom) (-thread-cell Univ))
+   (pd-t (-thread-cell (-v a)) (b) (-thread-cell (-v a)) (-thread-cell (-v a)))
+
+   (pd-t (-HT (-v a) (-v a)) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
+   (pd-t (-HT (-lst (-v a)) (-lst (-v a))) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
+   (pd-t (-HT (-v a) (-v a)) (b) (-HT (-v a) (-v a)) (-HT (-v a) (-v a)))
+
+   (pd-t (-Param (-v a) (-v b)) (a b) (-Param Univ -Bottom) (-Param -Bottom Univ))
+   (pd-t (-Param (-lst (-v a)) (-lst (-v b))) (a b)
+         (-Param (-lst Univ) (-lst -Bottom))
+         (-Param (-lst -Bottom) (-lst Univ)))
+
+   (pd-t (->* (list (-lst (-v a))) (-lst (-v a)) (-lst (-v a))) (a)
+         (->* (list (-lst Univ)) (-lst Univ) (-lst -Bottom))
+         (->* (list (-lst -Bottom)) (-lst -Bottom) (-lst Univ)))
+
+   (pd-t (->key #:a (-lst (-v a)) #t #:b (-lst (-v a)) #f -Symbol) (a)
+         (->key #:a (-lst Univ) #t #:b (-lst Univ) #f -Symbol)
+         (->key #:a (-lst -Bottom) #t #:b (-lst -Bottom) #f -Symbol))
+
+   (pd-t (->... (list) ((-lst (-v a)) b) -Symbol) (a)
+         (->... (list) ((-lst Univ) b) -Symbol)
+         (->... (list) ((-lst -Bottom) b) -Symbol))))
+
+
 (define-syntax (infer-t stx)
   (syntax-parse stx
     ([_ S:expr T:expr . rest]
@@ -77,222 +174,149 @@
 (define-syntax-rule (i2-f t1 t2)
   (infer-t t2 t1 #:vars (fv t2) #:fail))
 
-(define N -Number)
-(define B -Boolean)
-
-(define-syntax (pd-t stx)
-  (syntax-parse stx
-    ([_ S:expr (vars:id ...) D:expr P:expr]
-     (quasisyntax/loc stx
-       (test-case (format "~a => ~a < ~a < ~a" '(vars ...) 'D 'S 'P)
-         (define S-v S)
-         (define promoted (var-promote S-v '(vars ...)))
-         (define demoted (var-demote S-v '(vars ...)))
-         #,(syntax/loc stx
-             (check-equal? promoted P "Promoted value doesn't match expected."))
-         #,(syntax/loc stx
-             (check-equal? demoted D "Demoted value doesn't match expected.")))))))
-
-
-(define fv-tests
-  (test-suite "Tests for fv"
-              (fv-t -Number)
-              [fv-t (-v a) a]
-              [fv-t (-poly (a) a)]
-              [fv-t (-poly (a b c d e) a)]
-              [fv-t (-poly (b) (-v a)) a]
-              [fv-t (-poly (b c d e) (-v a)) a]
-              [fv-t (-mu a (-lst a))]
-              [fv-t (-mu a (-lst (-pair a (-v b)))) b]
-
-              [fv-t (->* null (-v a) -Number) a] ;; check that a is CONTRAVARIANT
-              ))
-
-(define pd-tests
-  (test-suite "Tests for var-promote/var-demote"
-    (pd-t Univ () Univ Univ)
-    (pd-t (-v a) () (-v a) (-v a))
-    (pd-t (-v a) (a) -Bottom Univ)
-    (pd-t (-v a) (b) (-v a) (-v a))
-
-    (pd-t (-vec (-v a)) (a) (-vec -Bottom) (-vec Univ))
-    (pd-t (-vec (-lst (-v a))) (a) (-vec -Bottom) (-vec Univ))
-    (pd-t (-vec (-v a)) (b) (-vec (-v a)) (-vec (-v a)))
-
-    (pd-t (-box (-v a)) (a) (-box -Bottom) (-box Univ))
-    (pd-t (-box (-lst (-v a))) (a) (-box -Bottom) (-box Univ))
-    (pd-t (-box (-v a)) (b) (-box (-v a)) (-box (-v a)))
-
-    (pd-t (-channel (-v a)) (a) (-channel -Bottom) (-channel Univ))
-    (pd-t (-channel (-lst (-v a))) (a) (-channel -Bottom) (-channel Univ))
-    (pd-t (-channel (-v a)) (b) (-channel (-v a)) (-channel (-v a)))
-
-    (pd-t (-thread-cell (-v a)) (a) (-thread-cell -Bottom) (-thread-cell Univ))
-    (pd-t (-thread-cell (-lst (-v a))) (a) (-thread-cell -Bottom) (-thread-cell Univ))
-    (pd-t (-thread-cell (-v a)) (b) (-thread-cell (-v a)) (-thread-cell (-v a)))
-
-    (pd-t (-HT (-v a) (-v a)) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
-    (pd-t (-HT (-lst (-v a)) (-lst (-v a))) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
-    (pd-t (-HT (-v a) (-v a)) (b) (-HT (-v a) (-v a)) (-HT (-v a) (-v a)))
-
-    (pd-t (-Param (-v a) (-v b)) (a b) (-Param Univ -Bottom) (-Param -Bottom Univ))
-    (pd-t (-Param (-lst (-v a)) (-lst (-v b))) (a b)
-          (-Param (-lst Univ) (-lst -Bottom))
-          (-Param (-lst -Bottom) (-lst Univ)))
-
-    (pd-t (->* (list (-lst (-v a))) (-lst (-v a)) (-lst (-v a))) (a)
-          (->* (list (-lst Univ)) (-lst Univ) (-lst -Bottom))
-          (->* (list (-lst -Bottom)) (-lst -Bottom) (-lst Univ)))
-
-    (pd-t (->key #:a (-lst (-v a)) #t #:b (-lst (-v a)) #f -Symbol) (a)
-          (->key #:a (-lst Univ) #t #:b (-lst Univ) #f -Symbol)
-          (->key #:a (-lst -Bottom) #t #:b (-lst -Bottom) #f -Symbol))
-
-    (pd-t (->... (list) ((-lst (-v a)) b) -Symbol) (a)
-          (->... (list) ((-lst Univ) b) -Symbol)
-          (->... (list) ((-lst -Bottom) b) -Symbol))
-
-
-    ))
 
 (define infer-tests
-  (test-suite "Tests for infer"
-    (infer-t Univ Univ)
-    (infer-t (-v a) Univ)
-    (infer-t (-v a) (-v a) #:result [(-v a) (-v a)])
-    (infer-t Univ (-v a) #:fail)
-    (infer-t Univ (-v a) #:vars '(a))
-    (infer-t (-v a) Univ #:vars '(a))
-    (infer-t (-v a) -Bottom #:vars '(a))
-    (infer-t (-v a) (-v b) #:fail)
-    (infer-t (-v a) (-v b) #:vars '(a))
-    (infer-t (-v a) (-v b) #:vars '(b))
+  (test-suite
+   "Tests for infer"
+   (infer-t Univ Univ)
+   (infer-t (-v a) Univ)
+   (infer-t (-v a) (-v a) #:result [(-v a) (-v a)])
+   (infer-t Univ (-v a) #:fail)
+   (infer-t Univ (-v a) #:vars '(a))
+   (infer-t (-v a) Univ #:vars '(a))
+   (infer-t (-v a) -Bottom #:vars '(a))
+   (infer-t (-v a) (-v b) #:fail)
+   (infer-t (-v a) (-v b) #:vars '(a))
+   (infer-t (-v a) (-v b) #:vars '(b))
 
-    (infer-t (make-ListDots -Symbol 'b) (-lst -Symbol) #:indices '(b)
-             #:result [(make-ListDots (-v b) 'b) -Null])
-    (infer-t (make-ListDots (-v a) 'b) (-lst -Symbol) #:vars '(a) #:indices '(b)
-             #:result [(-lst* (make-ListDots (-v b) 'b) (-v a))
-                       (-lst* (-lst -Bottom) -Bottom)])
-    (infer-t (make-ListDots (-v b) 'b) (-lst -Symbol) #:indices '(b)
-             #:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
+   (infer-t (make-ListDots -Symbol 'b) (-lst -Symbol) #:indices '(b)
+            #:result [(make-ListDots (-v b) 'b) -Null])
+   (infer-t (make-ListDots (-v a) 'b) (-lst -Symbol) #:vars '(a) #:indices '(b)
+            #:result [(-lst* (make-ListDots (-v b) 'b) (-v a))
+                      (-lst* (-lst -Bottom) -Bottom)])
+   (infer-t (make-ListDots (-v b) 'b) (-lst -Symbol) #:indices '(b)
+            #:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
 
-    (infer-t (-lst -Symbol) (make-ListDots -Symbol 'b) #:indices '(b)
-             #:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
-    (infer-t (-lst -Symbol) (make-ListDots (-v b) 'b) #:indices '(b)
-             #:result [(make-ListDots (-v b) 'b) (-lst -Symbol)])
-    (infer-t (make-ListDots (-v b) 'b) (-lst Univ) #:indices '(b))
-    (infer-t (make-ListDots (-v a) 'a) (-lst Univ))
-    (infer-t (make-ListDots (-lst (-v a)) 'a) (-lst (-lst Univ)))
-    (infer-t (make-ListDots (-vec (-v a)) 'a) (-lst (-vec Univ)) #:fail)
+   (infer-t (-lst -Symbol) (make-ListDots -Symbol 'b) #:indices '(b)
+            #:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
+   (infer-t (-lst -Symbol) (make-ListDots (-v b) 'b) #:indices '(b)
+            #:result [(make-ListDots (-v b) 'b) (-lst -Symbol)])
+   (infer-t (make-ListDots (-v b) 'b) (-lst Univ) #:indices '(b))
+   (infer-t (make-ListDots (-v a) 'a) (-lst Univ))
+   (infer-t (make-ListDots (-lst (-v a)) 'a) (-lst (-lst Univ)))
+   (infer-t (make-ListDots (-vec (-v a)) 'a) (-lst (-vec Univ)) #:fail)
 
-    (infer-t (make-ListDots (-v a) 'b) (make-ListDots -Symbol 'b) #:vars '(a))
-    (infer-t (make-ListDots (-v b) 'b) (make-ListDots -Symbol 'b) #:indices '(b))
-    (infer-t (make-ListDots -Symbol 'b) (make-ListDots (-v b) 'b) #:indices '(b))
-    (infer-t (make-ListDots -Symbol 'b) (make-ListDots Univ 'b) #:indices '(b))
-    (infer-t (make-ListDots (-v b) 'b) (make-ListDots (-v b) 'b) #:indices '(b))
-    (infer-t (make-ListDots (-v b) 'b) (make-ListDots Univ 'b) #:indices '(b))
-    (infer-t (-pair (-v a) (make-ListDots (-v b) 'b))
-             (-pair (-v a) (make-ListDots (-v b) 'b))
-             #:result [(-v a) (-v a)])
+   (infer-t (make-ListDots (-v a) 'b) (make-ListDots -Symbol 'b) #:vars '(a))
+   (infer-t (make-ListDots (-v b) 'b) (make-ListDots -Symbol 'b) #:indices '(b))
+   (infer-t (make-ListDots -Symbol 'b) (make-ListDots (-v b) 'b) #:indices '(b))
+   (infer-t (make-ListDots -Symbol 'b) (make-ListDots Univ 'b) #:indices '(b))
+   (infer-t (make-ListDots (-v b) 'b) (make-ListDots (-v b) 'b) #:indices '(b))
+   (infer-t (make-ListDots (-v b) 'b) (make-ListDots Univ 'b) #:indices '(b))
+   (infer-t (-pair (-v a) (make-ListDots (-v b) 'b))
+            (-pair (-v a) (make-ListDots (-v b) 'b))
+            #:result [(-v a) (-v a)])
 
-    [infer-t (->... null ((-v a) a) (-v b)) (-> -Symbol -String) #:vars '(b) #:indices '(a)]
-    [infer-t (->... null ((-v a) a) (make-ListDots (-v a) 'a)) (-> -String -Symbol  (-lst* -String -Symbol)) #:indices '(a)]
-    [infer-t (->... (list (-v b)) ((-v a) a) (-v b)) (-> -String -Symbol -String) #:vars '(b) #:indices '(a)]
-    [infer-t (->... (list (-v b)) ((-v a) a) (-v b))
-             (->... (list -Symbol) (-String a) (-v b))
-             #:vars '(b) #:indices '(a)
-             #:result [(-lst* (make-ListDots (-v a) 'a) (-v b))
-                       (-lst* (-lst -String) -Symbol)]]
-    [infer-t (->* (list -Symbol) -String -Void)
-             (->... (list) ((-v a) a) -Void)
-             #:indices '(a)
-             #:result [(-lst* (make-ListDots (-v a) 'a))
-                       (-lst* (-lst* -Bottom #:tail (-lst -Bottom)))]]
-    [infer-t (->* (list) -String -Void) (->... (list) (-String a) -Void)]
+   [infer-t (->... null ((-v a) a) (-v b)) (-> -Symbol -String) #:vars '(b) #:indices '(a)]
+   [infer-t (->... null ((-v a) a) (make-ListDots (-v a) 'a)) (-> -String -Symbol  (-lst* -String -Symbol)) #:indices '(a)]
+   [infer-t (->... (list (-v b)) ((-v a) a) (-v b)) (-> -String -Symbol -String) #:vars '(b) #:indices '(a)]
+   [infer-t (->... (list (-v b)) ((-v a) a) (-v b))
+            (->... (list -Symbol) (-String a) (-v b))
+            #:vars '(b) #:indices '(a)
+            #:result [(-lst* (make-ListDots (-v a) 'a) (-v b))
+                      (-lst* (-lst -String) -Symbol)]]
+   [infer-t (->* (list -Symbol) -String -Void)
+            (->... (list) ((-v a) a) -Void)
+            #:indices '(a)
+            #:result [(-lst* (make-ListDots (-v a) 'a))
+                      (-lst* (-lst* -Bottom #:tail (-lst -Bottom)))]]
+   [infer-t (->* (list) -String -Void) (->... (list) (-String a) -Void)]
 
-    [infer-l (list (->... null ((-v b) b) (-v a))  (-> (-v a) -Boolean))
-             (list (-> -String            -Symbol) (-> -Symbol   -Boolean))
-             #:vars '(a)
-             #:indices '(b)]
-    [infer-l (list (->... null ((-v a) a) (-v b)) (make-ListDots (-v a) 'a))
-             (list (-> -Symbol -Symbol -String) (-lst* -Symbol -Symbol))
-             #:vars '(b)
-             #:indices '(a)]
+   [infer-l (list (->... null ((-v b) b) (-v a))  (-> (-v a) -Boolean))
+            (list (-> -String            -Symbol) (-> -Symbol   -Boolean))
+            #:vars '(a)
+            #:indices '(b)]
+   [infer-l (list (->... null ((-v a) a) (-v b)) (make-ListDots (-v a) 'a))
+            (list (-> -Symbol -Symbol -String) (-lst* -Symbol -Symbol))
+            #:vars '(b)
+            #:indices '(a)]
 
-    [infer-t (-> (-values (list -String))) (-> (-values-dots (list) -Symbol 'b)) #:indices '(b) #:fail]
-    [infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
-    [infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(a) #:fail]
-    [infer-t (-lst* -String) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
-    [infer-t (->* (list -Symbol) -Symbol -Void) (->* (list) (-v a) -Void) #:vars '(a) #:fail]
+   [infer-t (-> (-values (list -String))) (-> (-values-dots (list) -Symbol 'b)) #:indices '(b) #:fail]
+   [infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
+   [infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(a) #:fail]
+   [infer-t (-lst* -String) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
+   [infer-t (->* (list -Symbol) -Symbol -Void) (->* (list) (-v a) -Void) #:vars '(a) #:fail]
 
-    [infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
-    [infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
+   [infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
+   [infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
 
-    [infer-t
-     (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
-     (-lst* (-> Univ Univ))
-     #:indices '(b) #:fail]
-    [infer-t
-     (-lst* (-> Univ Univ))
-     (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
-     #:indices '(b) #:fail]
-    [infer-t
-     (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
-     (-pair (-> -Symbol Univ) (-lst -String))
-     #:indices '(b) #:fail]
-    [infer-t
-     (-pair (-> -Symbol Univ) (-lst -String))
-     (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
-     #:indices '(b) #:fail]
+   [infer-t
+    (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
+    (-lst* (-> Univ Univ))
+    #:indices '(b) #:fail]
+   [infer-t
+    (-lst* (-> Univ Univ))
+    (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
+    #:indices '(b) #:fail]
+   [infer-t
+    (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
+    (-pair (-> -Symbol Univ) (-lst -String))
+    #:indices '(b) #:fail]
+   [infer-t
+    (-pair (-> -Symbol Univ) (-lst -String))
+    (-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
+    #:indices '(b) #:fail]
 
-    [infer-t
-      (-lst (-mu A (Un (-v b) (-lst A))))
-      (-mu C (Un (-v b2) (-lst C)))
-      #:vars '(b2)
-      #:result [(-vec (-v b2)) (-vec (-lst (-mu A (Un (-v b) (-lst A)))))]]
+   [infer-t
+    (-lst (-mu A (Un (-v b) (-lst A))))
+    (-mu C (Un (-v b2) (-lst C)))
+    #:vars '(b2)
+    #:result [(-vec (-v b2)) (-vec (-lst (-mu A (Un (-v b) (-lst A)))))]]
 
-    [infer-t
-      (-mlst (-val 'b))
-      (-mlst (-v a))
-      #:vars '(a)
-      #:result [(-seq (-v a)) (-seq (-val 'b))]]
+   [infer-t
+    (-mlst (-val 'b))
+    (-mlst (-v a))
+    #:vars '(a)
+    #:result [(-seq (-v a)) (-seq (-val 'b))]]
 
-    [infer-t
-      (-lst (-val (-v a)))
-      (Un (-pair (-v a) Univ) -Null)
-      #:vars '(a)]
+   [infer-t
+    (-lst (-val (-v a)))
+    (Un (-pair (-v a) Univ) -Null)
+    #:vars '(a)]
 
-    ;; Currently Broken
-    ;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
-    [i2-t (-v a) N ('a N)]
-    [i2-t (-pair (-v a) (-v a)) (-pair N (Un N B)) ('a (Un N B))]
-    [i2-t (-lst (-v a)) (-lst* N N) ('a N)]
-    [i2-t (-lst (-v a)) (-lst* N B) ('a (Un N B))]
-    [i2-t Univ (Un N B)]
-    [i2-t ((-v a) . -> . (-v b)) (-> N N) ('b N) ('a (Un))]
-    [i2-t (-> (-v a) (-v a)) (->* null B B) ('a B)]
+   ;; Currently Broken
+   ;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
+   [i2-t (-v a) N ('a N)]
+   [i2-t (-pair (-v a) (-v a)) (-pair N (Un N B)) ('a (Un N B))]
+   [i2-t (-lst (-v a)) (-lst* N N) ('a N)]
+   [i2-t (-lst (-v a)) (-lst* N B) ('a (Un N B))]
+   [i2-t Univ (Un N B)]
+   [i2-t ((-v a) . -> . (-v b)) (-> N N) ('b N) ('a (Un))]
+   [i2-t (-> (-v a) (-v a)) (->* null B B) ('a B)]
 
 
-    [i2-l (list (-v a) (-v a) (-v b))
-          (list (Un (-val 1) (-val 2)) N N)
-          '(a b) ('b N) ('a N)]
-    [i2-l (list (-> (-v a) Univ) (-lst (-v a)))
-          (list (-> N (Un N B)) (-lst N))
-          '(a) ('a N)]
-    [i2-l (list (-> (-v a) (-v b)) (-lst (-v a)))
-          (list (-> N N) (-lst (Un (-val 1) (-val 2))))
-          '(a b) ('b N) ('a (Un (-val 1) (-val 2)))]
-    [i2-l (list  (-lst (-v a)))
-          (list  (-lst (Un B N)))
-          '(a) ('a (Un N B))]
-    ;; error tests
-    [i2-f (-lst (-v a)) Univ]
-    [i2-f (->* null B B) (-> (-v a) (-v b))]
-    ))
+   [i2-l (list (-v a) (-v a) (-v b))
+         (list (Un (-val 1) (-val 2)) N N)
+         '(a b) ('b N) ('a (Un (-val 2) N))]
+   [i2-l (list (-> (-v a) Univ) (-lst (-v a)))
+         (list (-> N (Un N B)) (-lst N))
+         '(a) ('a N)]
+   [i2-l (list (-> (-v a) (-v b)) (-lst (-v a)))
+         (list (-> N N) (-lst (Un (-val 1) (-val 2))))
+         '(a b) ('b N) ('a (Un (-val 1) (-val 2)))]
+   [i2-l (list  (-lst (-v a)))
+         (list  (-lst (Un B N)))
+         '(a) ('a (Un N B))]
+   ;; error tests
+   [i2-f (-lst (-v a)) Univ]
+   [i2-f (->* null B B) (-> (-v a) (-v b))]
+   ))
 
 
 (define tests
-  (test-suite "All inference tests"
-    pd-tests
-    fv-tests
-    infer-tests))
+  (test-suite
+   "All inference tests"
+   fv-tests
+   fi-tests
+   pd-tests
+   infer-tests
+   ))
diff --git a/typed-racket-test/unit-tests/init-env-tests.rkt b/typed-racket-test/unit-tests/init-env-tests.rkt
index fdf89e8d..4927584f 100644
--- a/typed-racket-test/unit-tests/init-env-tests.rkt
+++ b/typed-racket-test/unit-tests/init-env-tests.rkt
@@ -4,7 +4,7 @@
          rackunit
          (rep object-rep type-rep)
          (env init-envs)
-         (types abbrev union))
+         (types abbrev))
 
 (provide tests)
 (gen-test-main)
@@ -29,16 +29,16 @@
         (convert (-mu x (-lst* Univ (-box x))))
         '(make-Mu 'x (make-Pair Univ (make-Pair (make-Box (make-F 'x)) -Null))))
       (check-equal?
-        (convert (make-StructTypeTop))
+        (convert -StructTypeTop)
         '-StructTypeTop)
       (check-equal?
-        (convert (make-BoxTop))
+        (convert -BoxTop)
         '-BoxTop)
       (check-equal?
-        (convert (make-ClassTop))
+        (convert -ClassTop)
         '-ClassTop)
       (check-equal?
-        (convert (make-FieldPE))
+        (convert -field)
         '-field)
       (check-equal?
         (convert (make-StructType (make-Struct #'foo #f null #f #f #'foo?)))
diff --git a/typed-racket-test/unit-tests/metafunction-tests.rkt b/typed-racket-test/unit-tests/metafunction-tests.rkt
index c88ef811..e6e7b6b2 100644
--- a/typed-racket-test/unit-tests/metafunction-tests.rkt
+++ b/typed-racket-test/unit-tests/metafunction-tests.rkt
@@ -4,7 +4,7 @@
          rackunit racket/format
          (typecheck tc-metafunctions tc-subst)
          (rep prop-rep type-rep object-rep values-rep)
-         (types abbrev union prop-ops tc-result numeric-tower)
+         (types abbrev prop-ops tc-result numeric-tower)
          (for-syntax racket/base syntax/parse))
 
 (provide tests)
diff --git a/typed-racket-test/unit-tests/parse-type-tests.rkt b/typed-racket-test/unit-tests/parse-type-tests.rkt
index ec6f9777..3ac1df2d 100644
--- a/typed-racket-test/unit-tests/parse-type-tests.rkt
+++ b/typed-racket-test/unit-tests/parse-type-tests.rkt
@@ -13,7 +13,7 @@
            (rep type-rep values-rep)
 
            (submod typed-racket/base-env/base-types initialize)
-           (rename-in (types union abbrev numeric-tower resolve)
+           (rename-in (types abbrev numeric-tower resolve)
                       [Un t:Un] [-> t:->] [->* t:->*]))
          (only-in typed-racket/typed-racket do-standard-inits)
          (base-env base-types base-types-extra colon)
@@ -68,7 +68,7 @@
                             [delay-errors? #f])
                 (define expected ty-val)
                 (define actual (parse-type (quote-syntax ty-stx)))
-                #`(values #,expected #,actual #,(type-equal? actual expected)))))
+                #`(values #,expected #,actual #,(equal? actual expected)))))
           (unless same?
             (with-check-info (['expected expected] ['actual actual])
               (fail-check "Unequal types")))))]))
@@ -252,7 +252,7 @@
    [(Struct-Type arity-at-least) (make-StructType (resolve -Arity-At-Least))]
    [FAIL (Struct-Type Integer)]
    [FAIL (Struct-Type foo)]
-   [Struct-TypeTop (make-StructTypeTop)]
+   [Struct-TypeTop -StructTypeTop]
 
    ;; keyword function types
    [(#:a String -> String)
@@ -396,7 +396,7 @@
     (make-Unit null null null (-values (list -Void)))]
    [(Unit (import) (export))
     (make-Unit null null null (-values (list -Void)))]
-   [UnitTop (make-UnitTop)]
+   [UnitTop -UnitTop]
    [FAIL (Unit (export) String)]
    [FAIL (Unit (import) String)]
    [FAIL (Unit (init-depend) String)]
diff --git a/typed-racket-test/unit-tests/prop-tests.rkt b/typed-racket-test/unit-tests/prop-tests.rkt
index 2f9620c0..adae5ce4 100644
--- a/typed-racket-test/unit-tests/prop-tests.rkt
+++ b/typed-racket-test/unit-tests/prop-tests.rkt
@@ -3,7 +3,7 @@
 (require "test-utils.rkt"
          rackunit racket/format
          (rep prop-rep)
-         (types abbrev union prop-ops)
+         (types abbrev prop-ops)
          (for-syntax racket/base syntax/parse))
 
 (provide tests)
diff --git a/typed-racket-test/unit-tests/remove-intersect-tests.rkt b/typed-racket-test/unit-tests/remove-intersect-tests.rkt
index 5b31f7ef..478636ec 100644
--- a/typed-racket-test/unit-tests/remove-intersect-tests.rkt
+++ b/typed-racket-test/unit-tests/remove-intersect-tests.rkt
@@ -3,7 +3,7 @@
          (for-syntax racket/base)
          (r:infer infer)
          (rep type-rep)
-         (types abbrev numeric-tower subtype union subtract overlap)
+         (types abbrev numeric-tower subtype subtract overlap)
          rackunit)
 (provide tests)
 (gen-test-main)
@@ -57,7 +57,7 @@
     (-mu x (Un (Un -Number -Symbol) (-pair -Number x)))
     (-mu x (Un -Number (-pair -Number x)))]
    [(make-Listof (-mu x (Un -String (-HT -String x))))
-    (make-Listof (make-HashtableTop))
+    (make-Listof -HashtableTop)
     (make-Listof (-HT -String (-mu x (Un -String (-HT -String x)))))]))
 
 (define-syntax (remo-tests stx)
diff --git a/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt b/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt
index aaa7ae5f..37e0179a 100644
--- a/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt
+++ b/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt
@@ -5,9 +5,10 @@
          (for-syntax racket/base)
          (for-template racket/base)
          (rep type-rep prop-rep object-rep)
-         (for-syntax (rename-in (types utils union numeric-tower abbrev prop-ops)
-                                [Un t:Un]
-                                [-> t:->]))
+         (for-syntax
+          (rename-in (types utils numeric-tower abbrev prop-ops)
+                     [Un t:Un]
+                     [-> t:->]))
          (utils tc-utils utils)
          (utils mutated-vars)
 
@@ -18,7 +19,7 @@
          (for-syntax syntax/kerncase syntax/parse racket/syntax
                      (types abbrev numeric-tower utils)
                      (utils mutated-vars) (env mvar-env)
-                     (utils tc-utils) (typecheck typechecker))
+                     (utils tc-utils) (typecheck typechecker check-below))
          typed-racket/base-env/prims
          typed-racket/base-env/base-types
          (for-syntax typed-racket/standard-inits))
@@ -34,19 +35,23 @@
     [(tc-e expr ty) (syntax/loc stx (tc-e expr #:ret (reduce-tc-results/subsumption (ret ty))))]
     [(id a #:ret b)
      (syntax/loc stx
-       (test-case (format "~a ~a" (quote-line-number id) 'a)
-         (let-values
-           ([(res1 expanded)
-             (phase1-phase0-eval
+       (test-case
+        (format "~a ~a" (quote-line-number id) 'a)
+        (let*-values
+            ([(res1 res2 equiv? expanded)
+              (phase1-phase0-eval
                (let ([ex (local-expand #'a 'expression null)])
                  (find-mutated-vars ex mvar-env)
-                 #`(values '#,(tc-expr ex) '#,(syntax->datum ex))))]
-            [(res2) (phase1-phase0-eval #`'#,b)])
-           (with-check-info (['expanded expanded])
-             (unless (tc-result-equal/test? res1 res2)
-               (fail-check (format "Expression didn't have expected type.\n Expected: ~a\n Actual: ~a\n"
-                                   (struct->vector res1)
-                                   (struct->vector res2))))))))]))
+                 (let ([res1 (tc-expr ex)]
+                       [res2 b])
+                   (let ([equiv? (and (check-below res1 res2)
+                                      (check-below res2 res1))])
+                     #`(values '#,res1 '#,res2 '#,equiv? '#,(syntax->datum ex))))))])
+          (with-check-info (['expanded expanded])
+            (unless equiv?
+              (fail-check (format "Expression didn't have expected type.\n Expected: ~a\n Actual: ~a\n"
+                                  (struct->vector res1)
+                                  (struct->vector res2))))))))]))
 
 (define tests
   (test-suite
diff --git a/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt b/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt
index 5deb5ca9..22be1782 100644
--- a/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt
+++ b/typed-racket-test/unit-tests/static-contract-conversion-tests.rkt
@@ -9,7 +9,7 @@
            racket/base
            (private type-contract)
            (static-contracts instantiate)
-           (types abbrev numeric-tower union)))
+           (types abbrev numeric-tower)))
 
 (provide tests)
 (gen-test-main)
diff --git a/typed-racket-test/unit-tests/subst-tests.rkt b/typed-racket-test/unit-tests/subst-tests.rkt
index a0395775..c56c3681 100644
--- a/typed-racket-test/unit-tests/subst-tests.rkt
+++ b/typed-racket-test/unit-tests/subst-tests.rkt
@@ -8,18 +8,26 @@
 (gen-test-main)
 
 (define-syntax-rule (s img var tgt result)
-  (test-eq? (format "~a" '(img tgt)) (substitute img 'var tgt) result))
+  (test-equal? (format "~a" '(img tgt))
+               (substitute img 'var tgt)
+               result))
 
 
 (define-syntax-rule (s* imgs rest var tgt result)
-  (test-eq? (format "~a" '(img tgt)) (substitute-dots (list . imgs) rest 'var tgt) result))
+  (test-equal? (format "~a" '(img tgt))
+               (substitute-dots (list . imgs) rest 'var tgt)
+               result))
 
 (define-syntax-rule (s... imgs var tgt result)
-  (test-eq? (format "~a" '(img tgt)) (substitute-dots (list . imgs) #f 'var tgt) result))
+  (test-equal? (format "~a" '(img tgt))
+               (substitute-dots (list . imgs) #f 'var tgt)
+               result))
 
 (define tests
   (test-suite "Tests for substitution"
     (s -Number a (-v a) -Number)
+    (s -Number a (-pair (-v a) -String) (-pair -Number -String))
+    (s -Number a (-pair -String (-v a)) (-pair -String -Number))
     (s* (-Symbol -String) #f a (make-ListDots (-v a) 'a) (-lst* -Symbol -String))
     (s* (-Symbol -String) Univ a (make-ListDots (-v a) 'a) (-lst* -Symbol -String #:tail (-lst Univ)))
     (s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number))
diff --git a/typed-racket-test/unit-tests/subtype-tests.rkt b/typed-racket-test/unit-tests/subtype-tests.rkt
index 831af426..8cafe610 100644
--- a/typed-racket-test/unit-tests/subtype-tests.rkt
+++ b/typed-racket-test/unit-tests/subtype-tests.rkt
@@ -1,7 +1,7 @@
 #lang racket/base
 
 (require "test-utils.rkt"
-         (types subtype numeric-tower union utils abbrev)
+         (types subtype numeric-tower utils abbrev)
          (rep type-rep values-rep)
          (env init-envs type-env-structs)
          rackunit
@@ -10,69 +10,252 @@
 (provide tests)
 (gen-test-main)
 
+(define-for-syntax (single-subtype-test stx)
+  (syntax-case stx (FAIL)
+    [(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s)) (lambda (a b) (not (subtype a b))) t s))]
+    [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subtype t s))]))
+
 (define-syntax (subtyping-tests stx)
-  (define (single-test stx)
-    (syntax-case stx (FAIL)
-      [(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s)) (lambda (a b) (not (subtype a b))) t s))]
-      [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subtype t s))]))
+  (syntax-case stx ()
+    [(_ str cl ...)
+     (with-syntax ([(new-cl ...) (map single-subtype-test (syntax->list #'(cl ...)))])
+       (syntax/loc stx
+         (begin (test-suite (format "Tests for subtyping (~a)" str)
+                            new-cl ...))))]))
+
+(define x1 #'x)
+(define x2 #'x)
+(define A (make-F (gensym 'A)))
+(define B (make-F (gensym 'B)))
+(define AorB (Un A B))
+(define t1a (-mu T (-lst (Un (-v a) T))))
+(define t1b (unfold t1a))
+(define t2 -Number)
+
+(define-for-syntax (covariant-test stx)
+  (syntax-case stx ()
+    [(mk []) (syntax/loc stx
+               (subtyping-tests
+                (format "covariant tests for ~a" mk)
+                [(mk A) (mk A)]
+                [(mk t1a) (mk t1b)]
+                [(mk A) (mk AorB)]
+                [FAIL (mk AorB) (mk A)]
+                [FAIL (mk Univ) A]
+                [FAIL A (mk Univ)]))]
+    [(mk [] [])
+     (syntax/loc stx
+       (subtyping-tests
+        (format "covariant tests for ~a" mk)
+        [(mk A B) (mk A B)]
+        [(mk A B) (mk AorB B)]
+        [(mk A B) (mk A AorB)]
+        [(mk A B) (mk AorB AorB)]
+        [(mk t1a t1a) (mk t1b t1b)]
+        [FAIL (mk AorB B) (mk A B)]
+        [FAIL (mk A AorB) (mk A B)]
+        [FAIL (mk AorB AorB) (mk A B)]
+        [FAIL (mk Univ Univ) A]
+        [FAIL A (mk Univ Univ)]))]))
+
+(define-syntax (covariant-tests stx)
   (syntax-case stx ()
     [(_ cl ...)
-     (with-syntax ([(new-cl ...) (map single-test (syntax->list #'(cl ...)))])
-                  (syntax/loc stx
-                              (begin (test-suite "Tests for subtyping"
-                                                 new-cl ...))))]))
+     (with-syntax ([(co-tests ...) (map covariant-test (syntax->list #'(cl ...)))])
+       (syntax/loc stx
+         (begin co-tests ...)))]))
+
+(define-for-syntax (invariant-test stx)
+  (syntax-case stx ()
+    [(mk () #:top top)
+     (syntax/loc stx
+       (subtyping-tests
+        (format "invariant tests for ~a" mk)
+        [(mk A) (mk A)]
+        [(mk t1a) (mk t1b)]
+        [(mk A) top]
+        [FAIL top (mk A)]
+        [FAIL (mk A) (mk AorB)]
+        [FAIL (mk AorB) (mk A)]
+        [FAIL (mk Univ) A]
+        [FAIL A (mk Univ)]))]
+    [(mk () () #:top top)
+     (syntax/loc stx
+       (subtyping-tests
+        (format "invariant tests for ~a" mk)
+        [(mk A B) (mk A B)]
+        [(mk t1a t1a) (mk t1b t1b)]
+        [(mk A B) top]
+        [FAIL top (mk A B)]
+        [FAIL (mk A B) (mk AorB B)]
+        [FAIL (mk A B) (mk A AorB)]
+        [FAIL (mk A B) (mk AorB AorB)]
+        [FAIL (mk AorB B) (mk A B)]
+        [FAIL (mk A AorB) (mk A B)]
+        [FAIL (mk AorB AorB) (mk A B)]
+        [FAIL (mk Univ Univ) A]
+        [FAIL A (mk Univ Univ)]))]))
+
+(define-syntax (invariant-tests stx)
+  (syntax-case stx ()
+    [(_ cl ...)
+     (with-syntax ([(inv-tests ...) (map invariant-test (syntax->list #'(cl ...)))])
+       (syntax/loc stx
+         (begin inv-tests ...)))]))
 
 
-
-(define t1 (-mu T (-lst (Un (-v a) T))))
-(define t2 (unfold t1))
-
-(define tests
+(define simple-tests
   (subtyping-tests
-   ;; trivial examples
-   (Univ Univ)
-   (-Number Univ)
-   (-Boolean Univ)
-   (-Symbol Univ)
-   (-Void Univ)
-   [-Number -Number]
+   "Simple Subtyping Tests"
+   ;; trivial (⊤) examples
+   [Univ Univ]
+   [-Bottom Univ]
+   [-Number Univ]
+   [-Boolean Univ]
+   [-Symbol Univ]
+   [-Void Univ]
+   [FAIL Univ -Symbol]
+   [FAIL Univ -Number]
+   ;; Reflexivity
+   [(-val 6) (-val 6)]
+   [-Symbol -Symbol]
+   ;; Error
+   [Err -Number]
+   [-Number Err]
+   ;; B
+   [(make-B 0) (make-B 0)]
+   [FAIL (make-B 0) (make-B 1)]
+   ;; F
+   [(-v a) (-v a)]
+   [FAIL (-v a) (-v b)]
+   ;; Value
+   [(-val 'a) (-val 'a)]
+   [(-val 'a) -Symbol]
+   [FAIL -Symbol (-val 'a)]
+   [FAIL (-val 'a) (-val 'b)]
+   ;; Base
+   [-String -String]
+   [FAIL -Symbol -String]
+   ;; Opaque
+   [(make-Opaque x1) (make-Opaque x2)]
+   [FAIL (make-Opaque #'a) (make-Opaque #'b)]
+   ;; Refinement
+   [(make-Refinement A x1) (make-Refinement A x2)]
+   ;[(make-Refinement t1a x1) (make-Refinement t1b x1)]
+   ;[(make-Refinement t1a x1) t1b]
+   [FAIL (make-Refinement t2 x1) t1b]
+   [FAIL (make-Refinement A #'a) (make-Refinement A #'b)]
+   [FAIL (make-Refinement A x1) (make-Refinement B x1)]
+   ;; Distinction
+   [(-Distinction 'a 'b A) A]
+   [(-Distinction 'a 'b A) AorB]
+   [FAIL (-Distinction 'a 'b AorB) A]
+   ))
+
+(define structural-tests
+  (test-suite
+   "Structural Subtyping tests"
+   (covariant-tests
+    [make-Pair () ()]
+    [make-Promise ()]
+    [make-Ephemeron ()]
+    [make-CustodianBox ()]
+    [make-Set ()]
+    [make-Evt ()]
+    [make-Syntax ()]
+    [make-Future ()])
+   (invariant-tests
+    [make-MPair () () #:top -MPairTop]
+    [make-Vector () #:top -VectorTop]
+    [make-Box () #:top -BoxTop]
+    [make-Channel () #:top -ChannelTop]
+    [make-Async-Channel () #:top -Async-ChannelTop]
+    [make-ThreadCell () #:top -ThreadCellTop]
+    [make-Weak-Box () #:top -Weak-BoxTop]
+    [make-Hashtable () () #:top -HashtableTop]
+    [make-Prompt-Tagof () () #:top -Prompt-TagTop]
+    [make-Continuation-Mark-Keyof () #:top -Continuation-Mark-KeyTop])
+   (subtyping-tests
+    "Param"
+    [(make-Param A B) (make-Param A B)]
+    [(make-Param A B) (make-Param A AorB)]
+    [(make-Param AorB B) (make-Param A B)]
+    [FAIL (make-Param A B) (make-Param AorB B)]
+    [FAIL (make-Param A AorB) (make-Param A B)])
+   (subtyping-tests
+    "Evt special cases"
+    ;; evts
+    [(-evt t1a) (-evt t1b)]
+    [FAIL (-evt -Byte) (-evt -String)]
+    [-Semaphore (-evt -Semaphore)]
+    [FAIL -Semaphore (-evt -Int)]
+    [-Output-Port (-evt -Output-Port)]
+    [FAIL -Output-Port (-evt -Int)]
+    [-Input-Port (-evt -Input-Port)]
+    [FAIL -Input-Port (-evt -Int)]
+    [-TCP-Listener (-evt -TCP-Listener)]
+    [FAIL -TCP-Listener (-evt -Int)]
+    [-Thread (-evt -Thread)]
+    [FAIL -Thread (-evt -Int)]
+    [-Subprocess (-evt -Subprocess)]
+    [FAIL -Subprocess (-evt -Int)]
+    [-Will-Executor (-evt -Will-Executor)]
+    [FAIL -Will-Executor (-evt -Int)]
+    [(make-CustodianBox -String) (-evt (make-CustodianBox -String))]
+    [FAIL (make-CustodianBox -String) (-evt -String)]
+    [(-channel -String) (-evt -String)]
+    [FAIL (-channel -String) (-evt -Int)]
+    [-Log-Receiver (-evt (make-HeterogeneousVector
+                          (list -Symbol -String Univ
+                                (Un (-val #f) -Symbol))))]
+    [FAIL -Log-Receiver (-evt -Int)])
+   (subtyping-tests
+    "Sequence special cases"
+    [(-set -Number) (make-Sequence (list -Number))]
+    [-FlVector (make-Sequence (list -Flonum))]
+    [-FlVector (make-Sequence (list -Number))]
+    [-FxVector (make-Sequence (list -Fixnum))]
+    [-FxVector (make-Sequence (list -Number))]
+    [(-val 5) (-seq -Nat)]
+    [(-val 5) (-seq -Byte)]
+    [-Index (-seq -Index)]
+    [-NonNegFixnum (-seq -NonNegFixnum)]
+    [-Index (-seq -Nat)]
+    [FAIL (-val -5) (-seq -Nat)]
+    [FAIL -Fixnum (-seq -Fixnum)]
+    [FAIL -NonNegFixnum (-seq -Index)]
+    [FAIL (-val 5.0) (-seq -Nat)]
+    [(-pair -String (-lst -String)) (-seq -String)]
+    [FAIL (-pair -String (-lst -Symbol)) (-seq -String)]
+    [FAIL (-pair -String (-vec -String)) (-seq -String)]
+    [(-mpair -String -Null) (-seq -String)]
+    [(-mlst -String) (-seq -String)]
+    [(-mpair -String (-mlst -String)) (-seq -String)]
+    [FAIL (-mpair -String (-mlst -Symbol)) (-seq -String)]
+    [FAIL (-mpair -String (-vec -String)) (-seq -String)]
+    [(-mpair -String (-mlst (-val "hello"))) (-seq -String)])
+   (subtyping-tests
+    "Other Structural Cases"
+    [(-Param -String -Symbol) (cl->* (-> -Symbol) (-> -String -Void))]
+    [(-lst* -Number -Number (-val 'foo)) (-lst (Un -Number -Symbol))])))
+
+(define other-tests
+  (subtyping-tests
+   "Other Subtyping Tests"
+   ;; recursive types and unions
    [(Un (-pair Univ (-lst Univ)) -Null) (-lst Univ)]
    [(-lst* -Number -Number (-val 'foo)) (-lst Univ)]
-   [(-lst* -Number -Number (-val 'foo)) (-lst (Un -Number -Symbol))]
-   [(-pair (-val 6) (-val 6)) (-pair -Number -Number)]
-   [(-val 6) (-val 6)]
-   ;; unions
-   [(Un -Number) -Number]
-   [(Un -Number -Number) -Number]
-   [(Un -Number -Symbol) (Un -Symbol -Number)]
-   [(Un (-val 6) (-val 7)) -Number]
-   [(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))]
    [(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))]
    [(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x))))
     (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
-   ;; intersections
-    [(-unsafe-intersect -Number) -Number]
-    [(-unsafe-intersect -Number -Symbol) -Number]
-    [(-unsafe-intersect -Boolean -Number) -Number]
-    [(-unsafe-intersect -Number -Number) -Number]
-    [FAIL -Number (-unsafe-intersect -Boolean -Number)]
-    [(-unsafe-intersect -Boolean -Number) (-unsafe-intersect -Boolean -Number)]
-    [(-unsafe-intersect -Sexp
-                        (Un -Null (-pair -Sexp (-unsafe-intersect (make-Listof Univ) -Sexp))))
-     (make-Listof Univ)]
-    [(-unsafe-intersect (-v A) (-v B))
-     (Un -String (-unsafe-intersect (-v A) (-v B)))]
    ;; sexps vs list*s of nums
    [(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
    [(-mu x (Un -Number (make-Listof x))) (-mu x (Un -Number -Symbol (make-Listof x)))]
    [(-mu x (Un -Number (make-Listof x))) (-mu y (Un -Number -Symbol (make-Listof y)))]
    ;; a hard one
    [(-mu x (Un -Number (-lst* x -Symbol x))) -Sexp]
-   [t1 (unfold t1)]
-   [(unfold t1) t1]
-   ;; simple function types
-   ((Univ . -> . -Number) (-Number . -> . Univ))
-   [(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)]
+   [t1a (unfold t1a)]
+   [(unfold t1a) t1a]
    ;; simple list types
    [(make-Listof -Number) (make-Listof Univ)]
    [(make-Listof -Number) (make-Listof -Number)]
@@ -80,24 +263,10 @@
    [(-mu x (make-Listof x)) (-mu x* (make-Listof x*))]
    [(-pair -Number -Number) (-pair Univ -Number)]
    [(-pair -Number -Number) (-pair -Number -Number)]
-   ;; from page 7
+   ;; from page 7 (my favorite page! But seriously, page 7 of... what???)
    [(-mu t (-> t t)) (-mu s (-> s s))]
    [(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))]
-   ;; polymorphic types
-   [(-poly (t) (-> t t)) (-poly (s) (-> s s))]
-   [FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
-   [(-poly (a) (make-Listof (-v a))) (make-Listof -Number)]     ;;
-   [(-poly (a) -Number) -Number]
-
-   [(-val 6) -Number]
-   [(-val 'hello) -Symbol]
-   [(-set -Number) (make-Sequence (list -Number))]
-   [-FlVector (make-Sequence (list -Flonum))]
-   [-FlVector (make-Sequence (list -Number))]
-   [-FxVector (make-Sequence (list -Fixnum))]
-   [-FxVector (make-Sequence (list -Number))]
-   [((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)]
-   [(-poly (t) (-> -Number t)) (-mu t (-> -Number t))]
+    
    ;; not subtypes
    [FAIL (-val 'hello) -Number]
    [FAIL (-val #f) -Symbol]
@@ -108,10 +277,78 @@
    [FAIL -Symbol (-val 'Sym)]
    [FAIL (Un -Symbol -Number) (-poly (a) -Number)]
    ;; bugs found
-   [(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))]
+    
    [(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) -Number)))]
    [FAIL (make-Listof (-mu x (Un (make-Listof x) -Number))) (-poly (a) (make-Listof a))]
+
+   ;; HeterogeneousVector
+   [(make-HeterogeneousVector (list t1a)) (-vec t1b)]
+   [(make-HeterogeneousVector (list t1a t1a)) (-vec t1b)]
+   [FAIL (-vec t1b) (make-HeterogeneousVector (list t1a t1a))]
+   [FAIL (make-HeterogeneousVector (list t2)) (-vec t1b)]
+   [FAIL (make-HeterogeneousVector (list t1a t2)) (-vec t1b)]
+   [(make-HeterogeneousVector (list t1a t1b)) (make-HeterogeneousVector (list t1b t1a))]
+   [(make-HeterogeneousVector (list t1a t1b)) (make-HeterogeneousVector (list t1b t1a))]
+   [FAIL (make-HeterogeneousVector (list t1a)) (make-HeterogeneousVector (list t1b t1a))]
+   [FAIL (make-HeterogeneousVector (list t1a t2)) (make-HeterogeneousVector (list t1b t1a))]
+   [FAIL (make-HeterogeneousVector (list t2 t1a)) (make-HeterogeneousVector (list t1b t1a))]
+   ))
+
+(define set-theoretic-type-tests
+  (subtyping-tests
+   "Set-theoretic Subtyping"
+   ;; Unions
+   [(-val 0.0f0) -SingleFlonum]
+   [(-val -0.0f0) -SingleFlonum]
+   [(-val 1.0f0) -SingleFlonum]
    [(-val -34.2f0) -NegSingleFlonum]
+   [(-val 6) -Number]
+   [(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))]
+   [(Un -Number) -Number]
+   [(Un -Number -Number) -Number]
+   [(Un -Number -Symbol) (Un -Symbol -Number)]
+   [(Un (-val 6) (-val 7)) -Number]
+   [(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))]
+   ;; intersections
+   [(-unsafe-intersect -Number) -Number]
+   [(-unsafe-intersect -Number -Symbol) -Number]
+   [(-unsafe-intersect -Boolean -Number) -Number]
+   [(-unsafe-intersect -Number -Number) -Number]
+   [FAIL -Number (-unsafe-intersect -Boolean -Number)]
+   [(-unsafe-intersect -Boolean -Number) (-unsafe-intersect -Boolean -Number)]
+   [(-unsafe-intersect -Sexp
+                       (Un -Null (-pair -Sexp (-unsafe-intersect (make-Listof Univ) -Sexp))))
+    (make-Listof Univ)]
+   [(-unsafe-intersect (-v A) (-v B))
+    (Un -String (-unsafe-intersect (-v A) (-v B)))]
+   ))
+
+
+(define poly-tests
+  (subtyping-tests
+   "Polymorphic Subtyping"
+   [(-poly (t) (-> t t)) (-poly (s) (-> s s))]
+   [FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
+   [(-poly (a) (make-Listof (-v a))) (make-Listof -Number)]     ;;
+   [(-poly (a) -Number) -Number]
+   [FAIL (-poly (a) (-poly (b) (-pair a b))) (-poly (a) (-poly (b) (-pair b a)))]
+
+   ;; The following currently are not subtypes, because they are not replaceable
+   ;; in an instantiation context. It may be sound for them to be subtypes but
+   ;; the implications of that change are unknown.
+   [FAIL (-poly (x) (-lst x)) (-poly (x y) (-lst x))]
+   [FAIL (-poly (y z) (-lst y)) (-poly (z y) (-lst y))]
+   [FAIL (-poly (y) (-poly (z) (-pair y z))) (-poly (y z) (-pair y z))]
+   [FAIL (-poly (y z) (-pair y z)) (-poly (y) (-poly (z) (-pair y z)))]))
+
+(define function-tests
+  (subtyping-tests
+   "Function Subtyping"
+   ;; simple function types
+   [((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)]
+   [(-poly (t) (-> -Number t)) (-mu t (-> -Number t))]
+   ((Univ . -> . -Number) (-Number . -> . Univ))
+   [(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)]
    ;; case-lambda
    [(cl-> [(-Number) -Number] [(-Boolean) -Boolean]) (-Number . -> . -Number)]
    ;; special case for unused variables
@@ -132,8 +369,9 @@
                      [(-Number) a]))
     (cl-> [() (-pair -Number (-v b))]
           [(-Number) (-pair -Number (-v b))])]
-
-   ;[(-values (list -Number)) (-values (list Univ))]
+   ;; polymorphic function types should be subtypes of the function top
+   [(-poly (a) (a . -> . a)) top-func]
+   [FAIL (-> Univ) (null Univ . ->* . Univ)]
 
    [(-poly (b) ((Un (make-Base 'foo #'dummy values #f)
                     (-struct #'bar #f
@@ -142,126 +380,15 @@
     ((Un (make-Base 'foo #'dummy values #f) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f))))
      . -> . (-lst (-pair -Number (-v a))))]
    [(-poly (b) ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f))) . -> . (-lst b)))
-    ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f))) . -> . (-lst (-pair -Number (-v a))))]
+    ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)))
+     . -> .
+     (-lst (-pair -Number (-v a))))]
 
    [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
    [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
-
    [FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b))]
-   [FAIL (-poly (a) (-poly (b) (-pair a b))) (-poly (a) (-poly (b) (-pair b a)))]
-
-   ;; The following currently are not subtypes, because they are not replacable
-   ;; in an instantiation context. It may be sound for them to be subtypes but
-   ;; the implications of that change are unknown.
-   [FAIL (-poly (x) (-lst x)) (-poly (x y) (-lst x))]
-   [FAIL (-poly (y z) (-lst y)) (-poly (z y) (-lst y))]
-   [FAIL (-poly (y) (-poly (z) (-pair y z))) (-poly (y z) (-pair y z))]
-   [FAIL (-poly (y z) (-pair y z)) (-poly (y) (-poly (z) (-pair y z)))]
-
-
-   ;; polymorphic function types should be subtypes of the function top
-   [(-poly (a) (a . -> . a)) top-func]
-   (FAIL (-> Univ) (null Univ . ->* . Univ))
-
+    
    [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)]
-   [(-struct #'a #f null) (-struct #'a #f null)]
-   [(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld -String #'values #f)))]
-   [(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld Univ #'values #f)))]
-   [(-val 0.0f0) -SingleFlonum]
-   [(-val -0.0f0) -SingleFlonum]
-   [(-val 1.0f0) -SingleFlonum]
-   [(-pair -String (-lst -String)) (-seq -String)]
-   [FAIL (-pair -String (-lst -Symbol)) (-seq -String)]
-   [FAIL (-pair -String (-vec -String)) (-seq -String)]
-   [(-mpair -String -Null) (-seq -String)]
-   [(-mlst -String) (-seq -String)]
-   [(-mpair -String (-mlst -String)) (-seq -String)]
-   [FAIL (-mpair -String (-mlst -Symbol)) (-seq -String)]
-   [FAIL (-mpair -String (-vec -String)) (-seq -String)]
-   [(-mpair -String (-mlst (-val "hello"))) (-seq -String)]
-
-   [(-Param -Byte -Byte) (-Param (-val 0) -Int)]
-   [FAIL (-Param -Byte -Byte) (-Param -Int -Int)]
-   [(-Param -String -Symbol) (cl->* (-> -Symbol) (-> -String -Void))]
-
-   [(-vec t1) (-vec t2)]
-   [(make-HeterogeneousVector (list t1)) (-vec t2)]
-   [(make-HeterogeneousVector (list t1 t2)) (make-HeterogeneousVector (list t2 t1))]
-   [(-box t1) (-box t2)]
-   [(-thread-cell t1) (-thread-cell t2)]
-   [(-channel t1) (-channel t2)]
-   [(-mpair t1 t2) (-mpair t2 t1)]
-   [(-HT t1 t2) (-HT t2 t1)]
-   [(make-Prompt-Tagof t1 t2) (make-Prompt-Tagof t2 t1)]
-   [(make-Continuation-Mark-Keyof t1) (make-Continuation-Mark-Keyof t2)]
-
-   ;; evts
-   [(-evt t1) (-evt t2)]
-   [FAIL (-evt -Byte) (-evt -String)]
-   [-Semaphore (-evt -Semaphore)]
-   [FAIL -Semaphore (-evt -Int)]
-   [-Output-Port (-evt -Output-Port)]
-   [FAIL -Output-Port (-evt -Int)]
-   [-Input-Port (-evt -Input-Port)]
-   [FAIL -Input-Port (-evt -Int)]
-   [-TCP-Listener (-evt -TCP-Listener)]
-   [FAIL -TCP-Listener (-evt -Int)]
-   [-Thread (-evt -Thread)]
-   [FAIL -Thread (-evt -Int)]
-   [-Subprocess (-evt -Subprocess)]
-   [FAIL -Subprocess (-evt -Int)]
-   [-Will-Executor (-evt -Will-Executor)]
-   [FAIL -Will-Executor (-evt -Int)]
-   [(make-CustodianBox -String) (-evt (make-CustodianBox -String))]
-   [FAIL (make-CustodianBox -String) (-evt -String)]
-   [(-channel -String) (-evt -String)]
-   [FAIL (-channel -String) (-evt -Int)]
-   [-Log-Receiver (-evt (make-HeterogeneousVector
-                          (list -Symbol -String Univ
-                                (Un (-val #f) -Symbol))))]
-   [FAIL -Log-Receiver (-evt -Int)]
-
-   [(-val 5) (-seq -Nat)]
-   [(-val 5) (-seq -Byte)]
-   [-Index (-seq -Index)]
-   [-NonNegFixnum (-seq -NonNegFixnum)]
-   [-Index (-seq -Nat)]
-   [FAIL (-val -5) (-seq -Nat)]
-   [FAIL -Fixnum (-seq -Fixnum)]
-   [FAIL -NonNegFixnum (-seq -Index)]
-   [FAIL (-val 5.0) (-seq -Nat)]
-
-   [(-polydots (a) (->... (list Univ) (a a) (make-ValuesDots null a 'a)))
-    (-polydots (a) (->... (list -String) (a a) (make-ValuesDots null a 'a)))]
-
-   [(-polydots (a) (->... null (Univ a) (make-ValuesDots (list (-result a)) a 'a)))
-    (-polydots (a) (->... null (-String a) (make-ValuesDots (list (-result a)) a 'a)))]
-
-   [(-polydots (a) (->... null (a a) (make-ValuesDots (list (-result -String)) -String 'a)))
-    (-polydots (a) (->... null (a a) (make-ValuesDots (list (-result Univ)) Univ 'a)))]
-
-   [(-polydots (a) (->... null (Univ a) (-values (list Univ))))
-    (->* null Univ Univ)]
-
-
-   [(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
-    (-> -String -Symbol (-Tuple (list -String -Symbol)))]
-   [(-> -String -Symbol (-Tuple (list -String -Symbol)))
-    (-polydots (a) (-> -String -Symbol (-lst (Un -String -Symbol))))]
-
-   [(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
-    (-poly (a b) (-> a b (-Tuple (list a b))))]
-
-   [(-polydots (b a) (-> (->... (list b) (a a) (make-ValuesDots (list (-result b)) a 'a)) Univ))
-    (-polydots (a) (-> (->... (list) (a a) (make-ValuesDots null a 'a)) Univ))]
-
-   [(-polydots (a) (->... (list) (a a) (make-ListDots a 'a)))
-    (-polydots (b a) (->... (list b) (a a) (-pair b (make-ListDots a 'a))))]
-
-   [FAIL
-    (-polydots (c a b) (->... (list (->... (list a) (b b) c) (-vec a)) ((-vec b) b) (-vec c)))
-    (->* (list (->* (list) -Symbol -Symbol)) (-vec -Symbol) (-vec -Symbol))]
-
    [(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
     (-> Univ -Boolean : -tt-propset)]
    [(-> Univ -Boolean : -ff-propset)
@@ -284,9 +411,6 @@
    [FAIL (make-ListDots (-box (make-F 'a)) 'a) (-lst (-box Univ))]
    [(make-ListDots (-> -Symbol (make-F 'a)) 'a) (-lst (-> -Symbol Univ))]
 
-   ;[FAIL (make-ValuesDots (list) -Symbol 'a) (make-ValuesDots (list (-result -String)) -String 'a)]
-   ;[(-values (list -Bottom)) (-values (list -String -Symbol))]
-
    [(-> Univ -Bottom) (-> Univ (-values (list -String -Symbol)))]
    [(-> Univ -Bottom) (-> Univ (-values-dots null -String 'x))]
 
@@ -326,8 +450,67 @@
    [FAIL
     (->key -String #:x -Symbol #f #:y -Symbol #f Univ)
     (->optkey -String [-Void] #:x -Symbol #t Univ)]
+   
+   ;; Proposition subtyping
+   [(make-pred-ty (list -Real) -Boolean (Un (-val 0.0) (-val 0)))
+    (make-pred-ty (list -Int) -Boolean (-val 0))]
 
-   ;; classes and objects
+   [(-polydots (a) (->... (list Univ) (a a) (make-ValuesDots null a 'a)))
+    (-polydots (a) (->... (list -String) (a a) (make-ValuesDots null a 'a)))]
+
+   [(-polydots (a) (->... null (Univ a) (make-ValuesDots (list (-result a)) a 'a)))
+    (-polydots (a) (->... null (-String a) (make-ValuesDots (list (-result a)) a 'a)))]
+
+   [(-polydots (a) (->... null (a a) (make-ValuesDots (list (-result -String)) -String 'a)))
+    (-polydots (a) (->... null (a a) (make-ValuesDots (list (-result Univ)) Univ 'a)))]
+
+   [(-polydots (a) (->... null (Univ a) (-values (list Univ))))
+    (->* null Univ Univ)]
+
+   ;; ListDots
+   [(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
+    (-> -String -Symbol (-Tuple (list -String -Symbol)))]
+   [(-> -String -Symbol (-Tuple (list -String -Symbol)))
+    (-polydots (a) (-> -String -Symbol (-lst (Un -String -Symbol))))]
+
+   [(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
+    (-poly (a b) (-> a b (-Tuple (list a b))))]
+
+   [(-polydots (b a) (-> (->... (list b) (a a) (make-ValuesDots (list (-result b)) a 'a)) Univ))
+    (-polydots (a) (-> (->... (list) (a a) (make-ValuesDots null a 'a)) Univ))]
+
+   [(-polydots (a) (->... (list) (a a) (make-ListDots a 'a)))
+    (-polydots (b a) (->... (list b) (a a) (-pair b (make-ListDots a 'a))))]
+
+   [FAIL
+    (-polydots (c a b) (->... (list (->... (list a) (b b) c) (-vec a)) ((-vec b) b) (-vec c)))
+    (->* (list (->* (list) -Symbol -Symbol)) (-vec -Symbol) (-vec -Symbol))]))
+
+(define struct-tests
+  (subtyping-tests
+   "Struct Subtyping"
+   [(-struct x1 #f null) (-struct x2 #f null)]
+   [(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld -String #'values #f)))]
+   [(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld Univ #'values #f)))]
+   ;; prefab structs
+   [(-prefab 'foo -String) (-prefab 'foo -String)]
+   [(-prefab 'foo -String) (-prefab 'foo (-opt -String))]
+   [(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo -String)]
+   [(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo (-opt -String))]
+   [FAIL
+    (-prefab '(foo #(0)) -String) (-prefab '(foo #(0)) (-opt -String))]
+   [(-prefab '(foo 1 #(0)) -String -Symbol)
+    (-prefab '(foo #(0)) -String)]
+   [(-prefab '(bar foo 1 #(0)) -String -Symbol)
+    (-prefab '(foo #(0)) -String)]
+   [FAIL
+    (-prefab '(foo #()) -String) (-prefab '(foo #(0)) (-opt -String))]
+   ;; TODO StructType ?
+   ))
+
+(define oo-tests
+  (subtyping-tests
+   "Object Oriented Subtyping"
    [(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
     (-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))]
    [(-object #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
@@ -369,24 +552,43 @@
     (-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))]
    [FAIL
     (-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
-    (-class #:method ((m (-> -Nat))))]
+    (-class #:method ((m (-> -Nat))))]))
 
-   ;; prefab structs
-   [(-prefab 'foo -String) (-prefab 'foo -String)]
-   [(-prefab 'foo -String) (-prefab 'foo (-opt -String))]
-   [(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo -String)]
-   [(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo (-opt -String))]
-   [FAIL
-    (-prefab '(foo #(0)) -String) (-prefab '(foo #(0)) (-opt -String))]
-   [(-prefab '(foo 1 #(0)) -String -Symbol)
-    (-prefab '(foo #(0)) -String)]
-   [(-prefab '(bar foo 1 #(0)) -String -Symbol)
-    (-prefab '(foo #(0)) -String)]
-   [FAIL
-    (-prefab '(foo #()) -String) (-prefab '(foo #(0)) (-opt -String))]
+(define-for-syntax (single-subval-test stx)
+  (syntax-case stx (FAIL)
+    [(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s)) (lambda (a b) (not (subval a b))) t s))]
+    [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subval t s))]))
 
-   ;; Proposition subtyping
-   ((make-pred-ty (list -Real) -Boolean (Un (-val 0.0) (-val 0)))
-    (make-pred-ty (list -Int) -Boolean (-val 0)))
+(define-syntax (subval-tests stx)
+  (syntax-case stx ()
+    [(_ str cl ...)
+     (with-syntax ([(new-cl ...) (map single-subval-test (syntax->list #'(cl ...)))])
+       (syntax/loc stx
+         (begin (test-suite (format "Tests for subval (~a)" str)
+                            new-cl ...))))]))
 
+(define values-tests
+  (subval-tests
+   "SomeValues"
+   [(-values (list -Number))
+    (-values (list Univ))]
+   [FAIL (make-ValuesDots (list) -Symbol 'a)
+         (make-ValuesDots (list (-result -String)) -String 'a)]
+   [(-values (list -Bottom))
+    (-values (list -String -Symbol))]
    ))
+
+
+
+(define tests
+  (test-suite
+   "All Subtype Tests"
+   simple-tests
+   structural-tests
+   set-theoretic-type-tests
+   struct-tests
+   poly-tests
+   function-tests
+   oo-tests
+   values-tests
+   other-tests))
diff --git a/typed-racket-test/unit-tests/test-utils.rkt b/typed-racket-test/unit-tests/test-utils.rkt
index b85b02f2..ba3c2661 100644
--- a/typed-racket-test/unit-tests/test-utils.rkt
+++ b/typed-racket-test/unit-tests/test-utils.rkt
@@ -5,16 +5,23 @@
          racket/gui/dynamic
          typed-racket/utils/utils
          (for-syntax racket/base syntax/parse)
-         (types utils)
+         (types utils subtype)
+         (utils tc-utils)
+         (typecheck check-below)
          (rep type-rep)
          rackunit rackunit/text-ui)
 
 (provide private typecheck (rename-out [infer r:infer]) utils env rep types base-env static-contracts
          (all-defined-out))
 
-;; FIXME - do something more intelligent
-(define (tc-result-equal/test? a b)
-  (equal? a b))
+(define (tc-result-equal/test? res1 res2)
+  (define (below? res1 res2)
+    (parameterize ([delay-errors? #f])
+      (with-handlers ([exn:fail? (λ (_) #f)])
+        (check-below res1 res2)
+        #t)))
+  (and (below? res1 res2)
+       (below? res2 res1)))
 
 (define-syntax (check-type-equal? stx)
   (syntax-case stx ()
diff --git a/typed-racket-test/unit-tests/type-equal-tests.rkt b/typed-racket-test/unit-tests/type-equal-tests.rkt
index 70c3a2fa..fa4620b2 100644
--- a/typed-racket-test/unit-tests/type-equal-tests.rkt
+++ b/typed-racket-test/unit-tests/type-equal-tests.rkt
@@ -2,7 +2,7 @@
 
 (require "test-utils.rkt" (for-syntax racket/base)
          (rep type-rep)
-         (types abbrev numeric-tower union)
+         (types abbrev numeric-tower)
          rackunit)
 
 (provide tests)
@@ -15,8 +15,8 @@
   (define (single-test stx)
     (syntax-case stx (FAIL)
       [(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s))
-                                    (lambda (a b) (not (type-equal? a b))) t s))]
-      [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) type-equal? t s))]))
+                                    (lambda (a b) (not (equal? a b))) t s))]
+      [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) equal? t s))]))
   (syntax-case stx ()
     [(_ cl ...)
      #`(test-suite "Tests for type equality"
diff --git a/typed-racket-test/unit-tests/type-printer-tests.rkt b/typed-racket-test/unit-tests/type-printer-tests.rkt
index ae7f4c23..c180b6f8 100644
--- a/typed-racket-test/unit-tests/type-printer-tests.rkt
+++ b/typed-racket-test/unit-tests/type-printer-tests.rkt
@@ -11,7 +11,6 @@
          typed-racket/types/abbrev
          typed-racket/types/numeric-tower
          typed-racket/types/printer
-         typed-racket/types/union
          typed-racket/utils/tc-utils
          (submod typed-racket/base-env/base-types initialize))
 
@@ -43,7 +42,7 @@
     (check-prints-as? Univ "Any")
     (check-prints-as? (Un (-val #t) (-val #f)) "Boolean")
     (check-prints-as? (-lst -Nat) "(Listof Nonnegative-Integer)")
-    (check-prints-as? (make-App (-poly (a) (-lst a)) (list -Nat) #'foo)
+    (check-prints-as? (make-App (-poly (a) (-lst a)) (list -Nat))
                       "(Listof Nonnegative-Integer)")
     (check-prints-as? (make-Mu 'x (Un -Null (-pair -Nat (make-F 'x))))
                       "(Listof Nonnegative-Integer)")
@@ -172,7 +171,7 @@
                         "(Unit (import a^ b^) (export c^ d^) (init-depend b^) String)")
       (check-prints-as? (make-Unit (list a^ b^) (list c^ d^) (list b^ a^) (-values (list -String)))
                         "(Unit (import a^ b^) (export c^ d^) (init-depend b^ a^) String)"))
-    (check-prints-as? (make-UnitTop) "UnitTop"))
+    (check-prints-as? -UnitTop "UnitTop"))
    (test-suite
     "Pretty printing tests"
     (check-pretty-prints-as? (-val 3) "3")
diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt
index bf2f6e0a..53211228 100644
--- a/typed-racket-test/unit-tests/typecheck-tests.rkt
+++ b/typed-racket-test/unit-tests/typecheck-tests.rkt
@@ -39,9 +39,11 @@
 (module tester racket/base
   (require
     (submod ".." cross-phase-failure)
+    "test-utils.rkt"
     typed-racket/utils/utils
     racket/base racket/match
-    (rename-in (types prop-ops tc-result printer) [ret raw-ret])
+    (rep core-rep)
+    (rename-in (types prop-ops tc-result printer subtype) [ret raw-ret])
     syntax/parse
     (for-template (only-in typed-racket/typed-racket do-standard-inits))
     (typecheck typechecker check-below)
@@ -71,33 +73,31 @@
 
 
   (define (check-tc-results result golden #:name name)
-    (unless (equal? golden result)
+    (unless (tc-result-equal/test? golden result)
       (define base-message (format "~a did not return the expected value." name))
 
-      (define extra-message1
-        (if (parameterize ([delay-errors? #f])
-              (with-handlers ([exn:fail? (lambda (_) #f)])
-                (check-below result golden)
-                #t))
-            " It returned a more precise value."
-            ""))
-
-      (define extra-message2
+      (define extra-message
         (match* (result golden)
-          [((tc-result1: rt rf ro) (tc-result1: gt gf go))
-           (cond
-             [(not (equal? rt gt))
-              " The types don't match."]
-             [(not (equal? rf gf))
-              " The propositions don't match."]
-             [(not (equal? ro go))
-              " They objects don't match."])]
+          [((tc-result1: rt (PropSet: rp+ rp-) ro)
+            (tc-result1: gt (PropSet: gp+ gp-) go))
+           (string-append
+            (if (not (and (subtype rt gt)
+                          (subtype gt rt)))
+                " The types don't match."
+                "")
+            (if (not (and (prop-equiv? rp+ gp+)
+                          (prop-equiv? rp- gp-)))
+                " The propositions don't match."
+                "")
+            (if (not (equal? ro go))
+                " The objects don't match."
+                ""))]
           [(_ _) ""]))
 
       (raise (cross-phase-failure
               #:actual result
               #:expected golden
-              (string-append base-message extra-message1 extra-message2)))))
+              (string-append base-message extra-message)))))
 
   ;; test: syntax? tc-results? [(option/c tc-results?)]
   ;;       [(listof (list id type))] -> void?
@@ -322,7 +322,7 @@
   (for-syntax
     (rep core-rep type-rep prop-rep object-rep values-rep)
     (base-env base-structs)
-    (rename-in (types abbrev union numeric-tower prop-ops utils resolve)
+    (rename-in (types abbrev numeric-tower prop-ops utils resolve)
                [Un t:Un]
                [-> t:->])))
 
@@ -1712,7 +1712,7 @@
         (tc-e (syntax-position #'here) (-opt -PosInt))
         (tc-e (syntax-span #'here) (-opt -Nat))
         (tc-e (syntax-local-identifier-as-binding #'x) (-Syntax -Symbol))
-        (tc-e (syntax-debug-info #'x) -HashTop)
+        (tc-e (syntax-debug-info #'x) -HashtableTop)
         (tc-e (internal-definition-context-introduce (syntax-local-make-definition-context) #'x)
               (-Syntax (-val 'x)))
 
@@ -1906,7 +1906,7 @@
         (tc-e (sync (make-semaphore)) -Semaphore)
         (tc-e (sync (tcp-listen 5555)) -TCP-Listener)
         (tc-e (sync (tcp-listen 5555) (make-semaphore))
-              (make-Union (list -TCP-Listener -Semaphore)))
+              (t:Un -TCP-Listener -Semaphore))
         (tc-e (sync (thread (λ () 0))) -Thread)
         (tc-e (sync (make-will-executor)) -Will-Executor)
         (tc-e (sync (make-custodian-box (current-custodian) 0))
@@ -1923,9 +1923,9 @@
         (tc-e (sync (choice-evt (system-idle-evt))) -Void)
         (tc-e (sync (choice-evt (system-idle-evt)
                                 ((inst make-channel String))))
-              (make-Union (list -String -Void)))
+              (t:Un -String -Void))
         (tc-e (sync/timeout 100 (make-semaphore) (tcp-listen 5555))
-              (make-Union (list (-val #f) -TCP-Listener -Semaphore)))
+              (t:Un (-val #f) -TCP-Listener -Semaphore))
         (tc-e (handle-evt ((inst make-channel Number))
                           (λ: ([x : Number]) (number->string x)))
               (make-Evt -String))
@@ -2472,14 +2472,14 @@
                                           (make-struct-type 'foo #f 3 0)])
                               type))])
                parent)
-             (-opt (make-StructTypeTop))]
+             (-opt -StructTypeTop)]
        [tc-e (let-values ([(name _1 _2 getter setter _3 _4 _5)
                            (struct-type-info struct:arity-at-least)])
                (getter (arity-at-least 3) 0))
              Univ]
        [tc-e/t (assert (let-values ([(type _) (struct-info (arity-at-least 3))])
                        type))
-               (make-StructTypeTop)]
+               -StructTypeTop]
        [tc-err (let-values ([(name _1 _2 getter setter _3 _4 _5)
                              (struct-type-info struct:arity-at-least)])
                  (getter 'bad 0))
diff --git a/typed-racket-test/unit-tests/typed-units-tests.rkt b/typed-racket-test/unit-tests/typed-units-tests.rkt
index 2c1ee63d..8816283e 100644
--- a/typed-racket-test/unit-tests/typed-units-tests.rkt
+++ b/typed-racket-test/unit-tests/typed-units-tests.rkt
@@ -24,7 +24,7 @@
                     define lambda λ case-lambda)
          (prefix-in tr: (only-in (base-env prims) define lambda λ case-lambda))
          (for-syntax (rep type-rep prop-rep object-rep)
-                     (rename-in (types abbrev union numeric-tower prop-ops utils)
+                     (rename-in (types abbrev numeric-tower prop-ops utils)
                                 [Un t:Un]
                                 [-> t:->])))