diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
index 6aac041a..adba6e63 100644
--- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
+++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss
@@ -111,8 +111,8 @@
     (cl-> [() (-pair N (-v b))]
 	  [(N) (-pair N (-v b))])]
    
-   [(-poly (a) ((Un (-base 'foo) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a)))
-    ((Un (-base 'foo) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))]
+   [(-poly (a) ((Un (make-Base 'foo #f) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a)))
+    ((Un (make-Base 'foo #f) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))]
    [(-poly (a) ((-struct 'bar #f (list N a) #f #f #f values) . -> . (-lst a)))
     ((-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values) . -> . (-lst (-pair N (-v a))))]
    
diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
index 1e4c5c22..30462350 100644
--- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
+++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
@@ -7,6 +7,8 @@
 
 (provide type-equal-tests)
 
+(define (-base x) (make-Base x #f))
+
 
 (define-syntax (te-tests stx)
   (define (single-test stx)
diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss
index 4a03b910..e087666b 100644
--- a/collects/typed-scheme/env/init-envs.ss
+++ b/collects/typed-scheme/env/init-envs.ss
@@ -23,6 +23,7 @@
     (string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
   (match v
     [(Union: elems) `(make-Union (list ,@(map sub elems)))]
+    [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
     [(Name: stx) `(make-Name (quote-syntax ,stx))]
     [(Struct: name parent flds proc poly? pred-id cert)
      `(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier))]
diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss
index d244fb73..d2be5958 100644
--- a/collects/typed-scheme/private/remove-intersect.ss
+++ b/collects/typed-scheme/private/remove-intersect.ss
@@ -23,16 +23,16 @@
      (ormap (lambda (t*) (overlap t t*)) e)]
     [(or (list _ (? Poly?)) (list (? Poly?) _))
      #t] ;; these can have overlap, conservatively
-    [(list (Base: s1) (Base: s2)) (eq? s1 s2)]
-    [(list (Base: _) (Value: _)) (subtype t2 t1)] ;; conservative
-    [(list (Value: _) (Base: _)) (subtype t1 t2)] ;; conservative
+    [(list (Base: s1 _) (Base: s2 _)) (eq? s1 s2)]
+    [(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative
+    [(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative
     [(list (Syntax: t) (Syntax: t*))
      (overlap t t*)]
     [(or (list (Syntax: _) _)
          (list _ (Syntax: _)))
      #f]    
-    [(list (Base: _) _) #f]
-    [(list _ (Base: _)) #f]
+    [(list (Base: _ _) _) #f]
+    [(list _ (Base: _ _)) #f]
     [(list (Value: (? pair? v)) (Pair: _ _)) #t]
     [(list (Pair: _ _) (Value: (? pair? v))) #t]
     [(list (Pair: a b) (Pair: a* b*))
diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss
index 44387045..7263ca86 100644
--- a/collects/typed-scheme/private/subtype.ss
+++ b/collects/typed-scheme/private/subtype.ss
@@ -177,13 +177,13 @@
               ;; value types              
               [(list (Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))]
               ;; integers are numbers too
-              [(list (Base: 'Integer) (Base: 'Number)) A0]
+              [(list (Base: 'Integer _) (Base: 'Number _)) A0]
               ;; values are subtypes of their "type"
-              [(list (Value: (? integer? n)) (Base: 'Integer)) A0]
-              [(list (Value: (? number? n)) (Base: 'Number)) A0]
-              [(list (Value: (? boolean? n)) (Base: 'Boolean)) A0]
-              [(list (Value: (? symbol? n)) (Base: 'Symbol)) A0]
-              [(list (Value: (? string? n)) (Base: 'String)) A0]
+              [(list (Value: (? integer? n)) (Base: 'Integer _)) A0]
+              [(list (Value: (? number? n)) (Base: 'Number _)) A0]
+              [(list (Value: (? boolean? n)) (Base: 'Boolean _)) A0]
+              [(list (Value: (? symbol? n)) (Base: 'Symbol _)) A0]
+              [(list (Value: (? string? n)) (Base: 'String _)) A0]
               ;; tvars are equal if they are the same variable
               [(list (F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))]
               ;; case-lambda
diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss
index 22510c57..6776fe54 100644
--- a/collects/typed-scheme/private/type-effect-convenience.ss
+++ b/collects/typed-scheme/private/type-effect-convenience.ss
@@ -11,7 +11,8 @@
          "type-utils.ss" 
          scheme/promise
          (for-syntax macro-debugger/stxclass/stxclass)
-         (for-syntax scheme/base))
+         (for-syntax scheme/base)
+         (for-template scheme/base scheme/contract))
 
 (provide (all-defined-out) 
          ;; these should all eventually go away
@@ -114,27 +115,27 @@
     (lambda (t)
       (make-Struct s #f (list t) #f #f #'promise? values))))
 
-(define N (make-Base 'Number))
-(define -Integer (make-Base 'Integer))
-(define B (make-Base 'Boolean))
-(define Sym (make-Base 'Symbol))
-(define -Void (make-Base 'Void))
-(define -Bytes (make-Base 'Bytes))
-(define -Regexp (make-Base 'Regexp))
-(define -PRegexp (make-Base 'PRegexp))
-(define -Byte-Regexp (make-Base 'Byte-Regexp))
-(define -Byte-PRegexp (make-Base 'Byte-PRegexp))
-(define -String (make-Base 'String))
-(define -Keyword (make-Base 'Keyword))
-(define -Char (make-Base 'Char))
-(define -Syntax make-Syntax)
-(define -Prompt-Tag (make-Base 'Prompt-Tag))
-(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set))
-(define -Path (make-Base 'Path))
-(define -Namespace (make-Base 'Namespace))
-(define -Output-Port (make-Base 'Output-Port))
-(define -Input-Port (make-Base 'Input-Port))  
+(define N (make-Base 'Number #'number?))
+(define -Integer (make-Base 'Integer #'integer?))
+(define B (make-Base 'Boolean #'boolean?))
+(define Sym (make-Base 'Symbol #'symbol?))
+(define -Void (make-Base 'Void #'void?))
+(define -Bytes (make-Base 'Bytes #'bytes?))
+(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?))))
+(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?))))
+(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?))))
+(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?))
+(define -String (make-Base 'String #'string?))
+(define -Keyword (make-Base 'Keyword #'keyword?))
+(define -Char (make-Base 'Char #'char?))
+(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?))
+(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?))
+(define -Path (make-Base 'Path #'path?))
+(define -Namespace (make-Base 'Namespace #'namespace?))
+(define -Output-Port (make-Base 'Output-Port #'output-port?))
+(define -Input-Port (make-Base 'Input-Port #'input-port?))
 
+(define -Syntax make-Syntax)
 (define -HT make-Hashtable)
 (define -Promise make-promise-ty)
 
@@ -173,7 +174,6 @@
 
 
 (define -pair make-Pair)
-(define -base make-Base)
 
 (define -struct make-Struct)
 (define -val make-Value)
diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss
index c9f49f25..37f248c3 100644
--- a/collects/typed-scheme/private/type-effect-printer.ss
+++ b/collects/typed-scheme/private/type-effect-printer.ss
@@ -95,7 +95,7 @@
                       [else (fp "~a" v)])]
     [(? tuple? t)
      (fp "~a" (cons 'List (tuple-elems t)))]
-    [(Base: n) (fp "~a" n)]      
+    [(Base: n cnt) (fp "~a" n)]      
     [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
     [(Struct: 'Promise par (list fld) proc _ _ _) (fp "(Promise ~a)" fld)]      
     [(Struct: nm par flds proc _ _ _) 
@@ -138,10 +138,10 @@
     #;
     [(Mu-unsafe: b) (fp "(unsafe-mu ~a ~a)" (Type-seq c) b)]
     [(Mu: x (Syntax: (Union: (list
-                              (Base: 'Number) 
-                              (Base: 'Boolean)
-                              (Base: 'Symbol)
-                              (Base: 'String)
+                              (Base: 'Number _) 
+                              (Base: 'Boolean _)
+                              (Base: 'Symbol _)
+                              (Base: 'String _)
                               (Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var)))))
                               (Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y)))))
                               (Vector: (F: x))
diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss
index 4b6effb7..b5b54bf5 100644
--- a/collects/typed-scheme/rep/type-rep.ss
+++ b/collects/typed-scheme/rep/type-rep.ss
@@ -50,7 +50,7 @@
 (dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])  
 
 ;; name is a Symbol (not a Name)
-(dt Base (name) [#:frees #f] [#:fold-rhs #:base])
+(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name])
 
 ;; body is a Scope
 (dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]