diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/mzlib/private/contract-arr-checks.ss
new file mode 100644
index 0000000000..57ac711eb5
--- /dev/null
+++ b/collects/mzlib/private/contract-arr-checks.ss
@@ -0,0 +1,234 @@
+#lang scheme/base
+
+(provide (all-defined-out))
+(require scheme/private/contract-guts)
+
+(define empty-case-lambda/c
+  (flat-named-contract '(case->)
+                       (λ (x) (and (procedure? x) (null? (procedure-arity x))))))
+
+;; ----------------------------------------
+;; Checks and error functions used in macro expansions
+
+;; procedure-accepts-and-more? : procedure number -> boolean
+;; returns #t if val accepts dom-length arguments and
+;; any number of arguments more than dom-length. 
+;; returns #f otherwise.
+(define (procedure-accepts-and-more? val dom-length)
+  (let ([arity (procedure-arity val)])
+    (cond
+      [(number? arity) #f]
+      [(arity-at-least? arity)
+       (<= (arity-at-least-value arity) dom-length)]
+      [else
+       (let ([min-at-least (let loop ([ars arity]
+                                      [acc #f])
+                             (cond
+                               [(null? ars) acc]
+                               [else (let ([ar (car ars)])
+                                       (cond
+                                         [(arity-at-least? ar)
+                                          (if (and acc
+                                                   (< acc (arity-at-least-value ar)))
+                                              (loop (cdr ars) acc)
+                                              (loop (cdr ars) (arity-at-least-value ar)))]
+                                         [(number? ar)
+                                          (loop (cdr ars) acc)]))]))])
+         (and min-at-least
+              (begin
+                (let loop ([counts (sort (filter number? arity) >=)])
+                  (unless (null? counts)
+                    (let ([count (car counts)])
+                      (cond
+                        [(= (+ count 1) min-at-least)
+                         (set! min-at-least count)
+                         (loop (cdr counts))]
+                        [(< count min-at-least)
+                         (void)]
+                        [else (loop (cdr counts))]))))
+                (<= min-at-least dom-length))))])))
+
+(define (check->* f arity-count)
+  (unless (procedure? f)
+    (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+  (unless (and (procedure-arity-includes? f arity-count)
+               (no-mandatory-keywords? f))
+    (error 'object-contract 
+           "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
+           arity-count
+           f)))
+
+(define (get-mandatory-keywords f)
+  (let-values ([(mandatory optional) (procedure-keywords f)])
+    mandatory))
+
+(define (no-mandatory-keywords? f)
+  (let-values ([(mandatory optional) (procedure-keywords f)])
+    (null? mandatory)))
+
+(define (check->*/more f arity-count)
+  (unless (procedure? f)
+    (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
+  (unless (procedure-accepts-and-more? f arity-count)
+    (error 'object-contract 
+           "expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e"
+           arity-count
+           (if (= 1 arity-count) "" "s")
+           f)))
+
+
+(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
+  (unless pre-expr
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "pre-condition expression failure")))
+
+(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
+  (unless post-expr
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "post-condition expression failure")))
+
+(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
+  (unless (and (procedure? val)
+               (procedure-arity-includes?/optionals val dom-length optionals)
+               (keywords-match mandatory-kwds optional-keywords val))
+    (raise-contract-error
+     val
+     src-info
+     blame
+     orig-str
+     "expected a procedure that accepts ~a arguments~a, given: ~e"
+     dom-length
+     (keyword-error-text mandatory-kwds)
+     val)))
+
+(define (procedure-arity-includes?/optionals f base optionals)
+  (cond
+    [(zero? optionals) (procedure-arity-includes? f base)]
+    [else (and (procedure-arity-includes? f (+ base optionals))
+               (procedure-arity-includes?/optionals f base (- optionals 1)))]))
+
+(define (keywords-match mandatory-kwds optional-kwds val)
+  (let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
+    (and (equal? proc-mandatory mandatory-kwds)
+         (andmap (λ (kwd) (and (member kwd proc-all)
+                               (not (member kwd proc-mandatory))))
+                 optional-kwds))))
+
+(define (keyword-error-text mandatory-keywords)
+  (cond
+    [(null? mandatory-keywords) " without any keywords"]
+    [(null? (cdr mandatory-keywords))
+     (format " and the keyword ~a" (car mandatory-keywords))]
+    [else
+     (format
+      " and the keywords ~a~a"
+      (car mandatory-keywords)
+      (apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))]))
+
+(define ((check-procedure? arity) val)
+  (and (procedure? val)
+       (procedure-arity-includes? val arity)
+       (no-mandatory-keywords? val)))
+
+(define ((check-procedure/more? arity) val)
+  (and (procedure? val)
+       (procedure-accepts-and-more? val arity)))
+
+(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
+  (unless (procedure? val)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected a procedure, got ~e"
+                          val))
+  (unless (procedure-arity-includes? val arity)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected a ~a of arity ~a (not arity ~a), got  ~e"
+                          kind-of-thing
+                          arity
+                          (procedure-arity val)
+                          val)))
+
+(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
+  (unless (procedure? val)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected a procedure, got ~e"
+                          val))
+  (unless (procedure-accepts-and-more? val arity)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got  ~e"
+                          kind-of-thing
+                          arity
+                          (procedure-arity val)
+                          val)))
+
+(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str)
+  (unless (and (procedure? val)
+               (procedure-accepts-and-more? val dom-length)
+               (keywords-match mandatory-kwds optional-kwds val))
+    (raise-contract-error
+     val
+     src-info
+     blame
+     orig-str
+     "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
+     dom-length
+     (keyword-error-text mandatory-kwds)
+     val)))
+
+
+(define (check-rng-procedure who rng-x arity)
+  (unless (and (procedure? rng-x)
+               (procedure-arity-includes? rng-x arity))
+    (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
+           arity
+           rng-x)))
+
+(define (check-rng-procedure/more rng-mk-x arity)
+  (unless (and (procedure? rng-mk-x)
+               (procedure-accepts-and-more? rng-mk-x arity))
+    (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
+           arity 
+           rng-mk-x)))
+
+(define (check-rng-lengths results rng-contracts)
+  (unless (= (length results) (length rng-contracts))
+    (error '->d* 
+           "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" 
+           (length results) (length rng-contracts))))
+
+#|
+
+  test cases for procedure-accepts-and-more?
+
+  (and (procedure-accepts-and-more? (lambda (x . y) 1) 3)
+       (procedure-accepts-and-more? (lambda (x . y) 1) 2)
+       (procedure-accepts-and-more? (lambda (x . y) 1) 1)
+       (not (procedure-accepts-and-more? (lambda (x . y) 1) 0))
+       
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3)
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2)
+       (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1)
+       (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0))
+       
+       (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2)
+       (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1)
+       (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
+  
+  |#
diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss
new file mode 100644
index 0000000000..71b3a119b1
--- /dev/null
+++ b/collects/mzlib/private/contract-arr-obj-helpers.ss
@@ -0,0 +1,1112 @@
+#lang scheme/base
+(require syntax/stx 
+         syntax/name)
+
+(require (for-syntax scheme/base))
+(require (for-template scheme/base)
+         (for-template scheme/private/contract-guts)
+         (for-template "contract-arr-checks.ss"))
+
+(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h 
+         ->pp/h ->pp-rest/h 
+         make-case->/proc 
+         make-opt->/proc make-opt->*/proc)
+
+;; make-/proc : boolean
+;;              (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) 
+;;              syntax
+;;           -> (syntax -> syntax)
+(define (make-/proc method-proc? /h stx)
+  (let-values ([(arguments-check build-proj check-val first-order-check wrapper)
+                (/h method-proc? stx)])
+    (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
+      (with-syntax ([inner-check (check-val outer-args)]
+                    [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                    [(val-args body) (wrapper outer-args)])
+        (with-syntax ([inner-lambda
+                       (set-inferred-name-from
+                        stx
+                        (syntax/loc stx (lambda val-args body)))])
+          (let ([inner-lambda
+                 (syntax
+                  (lambda (val)
+                    inner-check
+                    inner-lambda))])
+            (with-syntax ([proj-code (build-proj outer-args inner-lambda)]
+                          [first-order-check first-order-check])
+              (arguments-check
+               outer-args
+               (syntax/loc stx
+                 (make-proj-contract
+                  name-id
+                  (lambda (pos-blame neg-blame src-info orig-str)
+                    proj-code)
+                  first-order-check))))))))))
+
+(define (make-case->/proc method-proc? stx inferred-name-stx select/h)
+  (syntax-case stx ()
+    
+    ;; if there are no cases, this contract should only accept the "empty" case-lambda.
+    [(_) (syntax empty-case-lambda/c)]
+    
+    ;; if there is only a single case, just skip it.
+    [(_ case) (syntax case)]
+    
+    [(_ cases ...)
+     (let-values ([(arguments-check build-projs check-val first-order-check wrapper) 
+                   (case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)])
+       (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
+         (with-syntax ([(inner-check ...) (check-val outer-args)]
+                       [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                       [(body ...) (wrapper outer-args)])
+           (with-syntax ([inner-lambda 
+                          (set-inferred-name-from
+                           inferred-name-stx
+                           (syntax/loc stx (case-lambda body ...)))])
+             (let ([inner-lambda
+                    (syntax
+                     (lambda (val)
+                       inner-check ...
+                       inner-lambda))])
+               (with-syntax ([proj-code (build-projs outer-args inner-lambda)]
+                             [first-order-check first-order-check])
+                 (arguments-check
+                  outer-args
+                  (syntax/loc stx
+                    (make-proj-contract
+                     (apply build-compound-type-name 'case-> name-id)
+                     (lambda (pos-blame neg-blame src-info orig-str)
+                       proj-code)
+                     first-order-check)))))))))]))
+
+(define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx)
+  (syntax-case stx (any)
+    [(_ (reqs ...) (opts ...) any)
+     (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)]
+    [(_ (reqs ...) (opts ...) res)
+     (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)]))
+
+(define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-stx)
+  (syntax-case stx (any)
+    [(_ (reqs ...) (opts ...) any)
+     (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
+            [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
+            [cses
+             (reverse
+              (let loop ([opt-vs (reverse opt-vs)])
+                (cond
+                  [(null? opt-vs) (list req-vs)]
+                  [else (cons (append req-vs (reverse opt-vs))
+                              (loop (cdr opt-vs)))])))])
+       (with-syntax ([(req-vs ...) req-vs]
+                     [(opt-vs ...) opt-vs]
+                     [((case-doms ...) ...) cses])
+         (with-syntax ([expanded-case->
+                        (make-case->/proc
+                         method-proc?
+                         (with-syntax ([case-> case-arr-stx]
+                                       [-> arr-stx])
+                           (syntax (case-> (-> case-doms ... any) ...)))
+                         inferred-name-stx
+                         select/h)])
+           (syntax/loc stx
+             (let ([req-vs reqs] ...
+                   [opt-vs opts] ...)
+               expanded-case->)))))]
+    [(_ (reqs ...) (opts ...) (ress ...))
+     (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))]
+            [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
+            [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
+            [cses
+             (reverse
+              (let loop ([opt-vs (reverse opt-vs)])
+                (cond
+                  [(null? opt-vs) (list req-vs)]
+                  [else (cons (append req-vs (reverse opt-vs))
+                              (loop (cdr opt-vs)))])))])
+       (with-syntax ([(res-vs ...) res-vs]
+                     [(req-vs ...) req-vs]
+                     [(opt-vs ...) opt-vs]
+                     [((case-doms ...) ...) cses])
+         (with-syntax ([(single-case-result ...)
+                        (let* ([ress-lst (syntax->list (syntax (ress ...)))]
+                               [only-one?
+                                (and (pair? ress-lst)
+                                     (null? (cdr ress-lst)))])
+                          (map
+                           (if only-one?
+                               (lambda (x) (car (syntax->list (syntax (res-vs ...)))))
+                               (lambda (x) (syntax (values res-vs ...))))
+                           cses))])
+           (with-syntax ([expanded-case->
+                          (make-case->/proc
+                           method-proc?
+                           (with-syntax ([case-> case-arr-stx]
+                                         [-> arr-stx])
+                             (syntax (case-> (-> case-doms ... single-case-result) ...)))
+                           inferred-name-stx
+                           select/h)])
+             (set-inferred-name-from
+              stx
+              (syntax/loc stx
+                (let ([res-vs ress] 
+                      ...
+                      [req-vs reqs]
+                      ...
+                      [opt-vs opts]
+                      ...)
+                  expanded-case->)))))))]))
+
+;; exactract-argument-lists : syntax -> (listof syntax)
+(define (extract-argument-lists stx)
+  (map (lambda (x)
+         (syntax-case x ()
+           [(arg-list body) (syntax arg-list)]))
+       (syntax->list stx)))
+
+;; ensure-cases-disjoint : syntax syntax[list] -> void
+(define (ensure-cases-disjoint stx cases)
+  (let ([individual-cases null]
+        [dot-min #f])
+    (for-each (lambda (case)
+                (let ([this-case (get-case case)])
+                  (cond
+                    [(number? this-case) 
+                     (cond
+                       [(member this-case individual-cases)
+                        (raise-syntax-error
+                         'case-> 
+                         (format "found multiple cases with ~a arguments" this-case)
+                         stx)]
+                       [(and dot-min (dot-min . <= . this-case))
+                        (raise-syntax-error 
+                         'case-> 
+                         (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case)
+                         stx)]
+                       [else (set! individual-cases (cons this-case individual-cases))])]
+                    [(pair? this-case)
+                     (let ([new-dot-min (car this-case)])
+                       (cond
+                         [dot-min
+                          (if (dot-min . <= . new-dot-min)
+                              (raise-syntax-error
+                               'case->
+                               (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min)
+                               stx)
+                              (set! dot-min new-dot-min))]
+                         [else
+                          (set! dot-min new-dot-min)]))])))
+              cases)))
+
+;; get-case : syntax -> (union number (cons number 'more))
+(define (get-case stx)
+  (let ([ilist (syntax->datum stx)])
+    (if (list? ilist)
+        (length ilist)
+        (cons 
+         (let loop ([i ilist])
+           (cond
+             [(pair? i) (+ 1 (loop (cdr i)))]
+             [else 0]))
+         'more))))
+
+
+;; case->/h : boolean
+;;            syntax
+;;            (listof syntax) 
+;;            select/h
+;;         -> (values (syntax -> syntax)
+;;                    (syntax -> syntax)
+;;                    (syntax -> syntax)
+;;                    (syntax syntax -> syntax) 
+;;                    (syntax -> syntax)
+;;                    (syntax -> syntax))
+;; like the other /h functions, but composes the wrapper functions
+;; together and combines the cases of the case-lambda into a single list.
+(define (case->/h method-proc? orig-stx cases select/h)
+  (let loop ([cases cases]
+             [name-ids '()])
+    (cond
+      [(null? cases) 
+       (values 
+        (lambda (outer-args body)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [body body]
+                        [(name-ids ...) (reverse name-ids)])
+            (syntax
+             (let ([name-id (list name-ids ...)])
+               body))))
+        (lambda (x y) y)
+        (lambda (args) (syntax ()))
+        (syntax (lambda (x) #t))
+        (lambda (args) (syntax ())))]
+      [else
+       (let ([/h (select/h (car cases) 'case-> orig-stx)]
+             [new-id (car (generate-temporaries (syntax (case->name-id))))])
+         (let-values ([(arguments-checks build-projs check-vals first-order-checks wrappers)
+                       (loop (cdr cases) (cons new-id name-ids))]
+                      [(arguments-check build-proj check-val first-order-check wrapper)
+                       (/h method-proc? (car cases))])
+           (values
+            (lambda (outer-args x) 
+              (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                            [new-id new-id])
+                (arguments-check 
+                 (syntax (val pos-blame neg-blame src-info orig-str new-id)) 
+                 (arguments-checks 
+                  outer-args
+                  x))))
+            (lambda (args inner) (build-projs args (build-proj args inner)))
+            (lambda (args)
+              (with-syntax ([checks (check-vals args)]
+                            [check (check-val args)])
+                (syntax (check . checks))))
+            (with-syntax ([checks first-order-checks]
+                          [check first-order-check])
+              (syntax (lambda (x) (and (checks x) (check x)))))
+            (lambda (args)
+              (with-syntax ([case (wrapper args)]
+                            [cases (wrappers args)])
+                (syntax (case . cases)))))))])))
+
+;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
+(define (ensure-no-duplicates stx form-name names)
+  (let ([ht (make-hash-table)])
+    (for-each (lambda (name)
+                (let ([key (syntax-e name)])
+                  (when (hash-table-get ht key (lambda () #f))
+                    (raise-syntax-error form-name
+                                        "duplicate method name"
+                                        stx
+                                        name))
+                  (hash-table-put! ht key #t)))
+              names)))
+
+;; method-specifier? : syntax -> boolean
+;; returns #t if x is the syntax for a valid method specifier
+(define (method-specifier? x)
+  (or (eq? 'public (syntax-e x))
+      (eq? 'override (syntax-e x))))
+
+;; prefix-super : syntax[identifier] -> syntax[identifier]
+;; adds super- to the front of the identifier
+(define (prefix-super stx)
+  (datum->syntax
+   #'here
+   (string->symbol
+    (format 
+     "super-~a"
+     (syntax->datum
+      stx)))))
+
+;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
+;; given the syntax for a method name, constructs the name of a method
+;; that returns the super's contract for the original method.
+(define (method-name->contract-method-name stx)
+  (datum->syntax
+   #'here
+   (string->symbol
+    (format 
+     "ACK_DONT_GUESS_ME-super-contract-~a"
+     (syntax->datum
+      stx)))))
+
+;; Each of the /h functions builds six pieces of syntax:
+;;  - [arguments-check]
+;;    code that binds the contract values to names and
+;;    does error checking for the contract specs
+;;    (were the arguments all contracts?)
+;;  - [build-proj]
+;;    code that partially applies the input contracts to build the projection
+;;  - [check-val]
+;;    code that does error checking on the contract'd value itself
+;;    (is it a function of the right arity?)
+;;  - [first-order-check]
+;;    predicate function that does the first order check and returns a boolean
+;;    (is it a function of the right arity?)
+;;  - [pos-wrapper]
+;;    a piece of syntax that has the arguments to the wrapper
+;;    and the body of the wrapper.
+;;  - [neg-wrapper]
+;;    a piece of syntax that has the arguments to the wrapper
+;;    and the body of the wrapper.
+;; the first function accepts a body expression and wraps
+;;    the body expression with checks. In addition, it
+;;    adds a let that binds the contract exprssions to names
+;;    the results of the other functions mention these names.
+;; the second and third function's input syntax should be five
+;;    names: val, blame, src-info, orig-str, name-id
+;; the fourth function returns a syntax list with two elements,
+;;    the argument list (to be used as the first arg to lambda,
+;;    or as a case-lambda clause) and the body of the function.
+;; They are combined into a lambda for the -> ->* ->d ->d* macros,
+;; and combined into a case-lambda for the case-> macro.
+
+;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->/h method-proc? stx)
+  (syntax-case stx ()
+    [(_) (raise-syntax-error '-> "expected at least one argument" stx)]
+    [(_ dom ... rng)
+     (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                   [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
+       (with-syntax ([(name-dom-contract-x ...)
+                      (if method-proc?
+                          (cdr
+                           (syntax->list
+                            (syntax (dom-contract-x ...))))
+                          (syntax (dom-contract-x ...)))])
+         (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
+           [any 
+            (values
+             (lambda (outer-args body)
+               (with-syntax ([body body]
+                             [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                 (syntax
+                  (let ([dom-contract-x (coerce-contract '-> dom)] ...)
+                    (let ([dom-x (contract-proc dom-contract-x)] ...)
+                      (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
+                        body))))))
+             
+             ;; proj
+             (lambda (outer-args inner-lambda)
+               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                             [inner-lambda inner-lambda])
+                 (syntax
+                  (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+                    inner-lambda))))
+             
+             (lambda (outer-args)
+               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                 (syntax
+                  (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
+             (syntax (check-procedure? dom-length))
+             (lambda (outer-args)
+               (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                 (syntax
+                  ((arg-x ...)
+                   (val (dom-projection-x arg-x) ...))))))]
+           [(values rng ...)
+            (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))]
+                          [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
+                          [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
+                          [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
+                          [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
+                          [(res-x ...) (generate-temporaries (syntax (rng ...)))])
+              (values
+               (lambda (outer-args body)
+                 (with-syntax ([body body]
+                               [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    (let ([dom-contract-x (coerce-contract '-> dom)] 
+                          ...
+                          [rng-contract-x (coerce-contract '-> rng)] ...)
+                      (let ([dom-x (contract-proc dom-contract-x)] 
+                            ...
+                            [rng-x (contract-proc rng-contract-x)]
+                            ...)
+                        (let ([name-id 
+                               (build-compound-type-name 
+                                '-> 
+                                name-dom-contract-x ...
+                                (build-compound-type-name 'values rng-contract-x ...))])
+                          body))))))
+               
+               ;; proj
+               (lambda (outer-args inner-lambda)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                               [inner-lambda inner-lambda])
+                   (syntax
+                    (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] 
+                          ...
+                          [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
+                      inner-lambda))))
+               
+               (lambda (outer-args)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
+               (syntax (check-procedure? dom-length))
+               
+               (lambda (outer-args)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    ((arg-x ...)
+                     (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
+                       (values (rng-projection-x
+                                res-x)
+                               ...))))))))]
+           [rng
+            (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))]
+                          [(rng-contact-x) (generate-temporaries (syntax (rng)))]
+                          [(rng-projection-x) (generate-temporaries (syntax (rng)))]
+                          [(rng-ant-x) (generate-temporaries (syntax (rng)))]
+                          [(res-x) (generate-temporaries (syntax (rng)))])
+              (values
+               (lambda (outer-args body)
+                 (with-syntax ([body body]
+                               [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    (let ([dom-contract-x (coerce-contract '-> dom)] 
+                          ...
+                          [rng-contract-x (coerce-contract '-> rng)])
+                      (let ([dom-x (contract-proc dom-contract-x)] 
+                            ...
+                            [rng-x (contract-proc rng-contract-x)])
+                        (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)])
+                          body))))))
+               
+               ;; proj
+               (lambda (outer-args inner-lambda)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                               [inner-lambda inner-lambda])
+                   (syntax
+                    (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] 
+                          ...
+                          [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)])
+                      inner-lambda))))
+               
+               (lambda (outer-args)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
+               (syntax (check-procedure? dom-length))
+               (lambda (outer-args)
+                 (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+                   (syntax
+                    ((arg-x ...)
+                     (let ([res-x (val (dom-projection-x arg-x) ...)])
+                       (rng-projection-x res-x))))))))])))]))
+
+;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->*/h method-proc? stx)
+  (syntax-case stx (any)
+    [(_ (dom ...) (rng ...))
+     (->/h method-proc? (syntax (-> dom ... (values rng ...))))]
+    [(_ (dom ...) any)
+     (->/h method-proc? (syntax (-> dom ... any)))]
+    [(_ (dom ...) rest (rng ...))
+     (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                   [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
+                   [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))]
+                   [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))]
+                   [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
+                   
+                   [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
+                   [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))]
+                   [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
+                   [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
+                   [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
+                   [(res-x ...) (generate-temporaries (syntax (rng ...)))]
+                   [arity (length (syntax->list (syntax (dom ...))))])
+       (values
+        (lambda (outer-args body)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [body body]
+                        [(name-dom-contract-x ...)
+                         (if method-proc?
+                             (cdr
+                              (syntax->list
+                               (syntax (dom-contract-x ...))))
+                             (syntax (dom-contract-x ...)))])
+            (syntax
+             (let ([dom-contract-x (coerce-contract '->* dom)] 
+                   ...
+                   [dom-rest-contract-x (coerce-contract '->* rest)]
+                   [rng-contract-x (coerce-contract '->* rng)] ...)
+               (let ([dom-x (contract-proc dom-contract-x)]
+                     ...
+                     [dom-rest-x (contract-proc dom-rest-contract-x)]
+                     [rng-x (contract-proc rng-contract-x)] 
+                     ...)
+                 (let ([name-id 
+                        (build-compound-type-name 
+                         '->*
+                         (build-compound-type-name dom-contract-x ...)
+                         dom-rest-contract-x
+                         (build-compound-type-name rng-contract-x ...))])
+                   body))))))
+        ;; proj
+        (lambda (outer-args inner-lambda)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [inner-lambda inner-lambda])
+            (syntax
+             (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] 
+                   ...
+                   [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]
+                   [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
+               inner-lambda))))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
+        (syntax (check-procedure/more? dom-length))
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             ((arg-x ... . arg-rest-x)
+              (let-values ([(res-x ...)
+                            (apply
+                             val
+                             (dom-projection-x arg-x)
+                             ...
+                             (dom-rest-projection-x arg-rest-x))])
+                (values (rng-projection-x res-x) ...))))))))]
+    [(_ (dom ...) rest any)
+     (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                   [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
+                   [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))]
+                   [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))]
+                   [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
+                   
+                   [arity (length (syntax->list (syntax (dom ...))))])
+       (values
+        (lambda (outer-args body)
+          (with-syntax ([body body]
+                        [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [(name-dom-contract-x ...)
+                         (if method-proc?
+                             (cdr
+                              (syntax->list
+                               (syntax (dom-contract-x ...))))
+                             (syntax (dom-contract-x ...)))])
+            (syntax
+             (let ([dom-contract-x (coerce-contract '->* dom)] 
+                   ...
+                   [dom-rest-contract-x (coerce-contract '->* rest)])
+               (let ([dom-x (contract-proc dom-contract-x)]
+                     ...
+                     [dom-rest-x (contract-proc dom-rest-contract-x)])
+                 (let ([name-id (build-compound-type-name
+                                 '->* 
+                                 (build-compound-type-name name-dom-contract-x ...)
+                                 dom-rest-contract-x
+                                 'any)])
+                   body))))))
+        ;; proj
+        (lambda (outer-args inner-lambda)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [inner-lambda inner-lambda])
+            (syntax
+             (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] 
+                   ...
+                   [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
+               inner-lambda))))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
+        (syntax (check-procedure/more? dom-length))
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             ((arg-x ... . arg-rest-x)
+              (apply
+               val
+               (dom-projection-x arg-x)
+               ...
+               (dom-projection-rest-x arg-rest-x))))))))]))
+
+;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->d/h method-proc? stx)
+  (syntax-case stx ()
+    [(_) (raise-syntax-error '->d "expected at least one argument" stx)]
+    [(_ dom ... rng)
+     (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))]
+                   [(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [arity (length (syntax->list (syntax (dom ...))))])
+       (values
+        (lambda (outer-args body)
+          (with-syntax ([body body]
+                        [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [(name-dom-contract-x ...)
+                         (if method-proc?
+                             (cdr
+                              (syntax->list
+                               (syntax (dom-contract-x ...))))
+                             (syntax (dom-contract-x ...)))])
+            (syntax
+             (let ([dom-contract-x (coerce-contract '->d dom)] ...)
+               (let ([dom-x (contract-proc dom-contract-x)] 
+                     ...
+                     [rng-x rng])
+                 (check-rng-procedure '->d rng-x arity)
+                 (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))])
+                   body))))))
+        
+        ;; proj
+        (lambda (outer-args inner-lambda)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [inner-lambda inner-lambda])
+            (syntax
+             (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+               inner-lambda))))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             (check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
+        
+        (syntax (check-procedure? arity))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             ((arg-x ...)
+              (let ([arg-x (dom-projection-x arg-x)] ...) 
+                (let ([rng-contract (rng-x arg-x ...)])
+                  (((contract-proc (coerce-contract '->d rng-contract))
+                    pos-blame
+                    neg-blame
+                    src-info
+                    orig-str)
+                   (val arg-x ...))))))))))]))
+
+;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->d*/h method-proc? stx)
+  (syntax-case stx ()
+    [(_ (dom ...) rng-mk)
+     (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                   [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
+       (values
+        (lambda (outer-args body)
+          (with-syntax ([body body]
+                        [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [(name-dom-contract-x ...)
+                         (if method-proc?
+                             (cdr
+                              (syntax->list
+                               (syntax (dom-contract-x ...))))
+                             (syntax (dom-contract-x ...)))])
+            (syntax
+             (let ([dom-contract-x (coerce-contract '->d* dom)] ...)
+               (let ([dom-x (contract-proc dom-contract-x)] 
+                     ...
+                     [rng-mk-x rng-mk])
+                 (check-rng-procedure '->d* rng-mk-x dom-length)
+                 (let ([name-id (build-compound-type-name
+                                 '->d* 
+                                 (build-compound-type-name name-dom-contract-x ...)
+                                 '(... ...))])
+                   body))))))
+        
+        ;; proj
+        (lambda (outer-args inner-lambda)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [inner-lambda inner-lambda])
+            (syntax
+             (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
+               inner-lambda))))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
+        (syntax (check-procedure? dom-length))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             ((arg-x ...)
+              (call-with-values
+               (lambda () (rng-mk-x arg-x ...))
+               (lambda rng-contracts
+                 (call-with-values
+                  (lambda ()
+                    (val (dom-projection-x arg-x) ...))
+                  (lambda results
+                    (check-rng-lengths results rng-contracts)
+                    (apply 
+                     values
+                     (map (lambda (rng-contract result)
+                            (((contract-proc (coerce-contract '->d* rng-contract))
+                              pos-blame
+                              neg-blame
+                              src-info
+                              orig-str)
+                             result))
+                          rng-contracts
+                          results))))))))))))]
+    [(_ (dom ...) rest rng-mk)
+     (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [(dom-rest-x) (generate-temporaries (syntax (rest)))]
+                   [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))]
+                   [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))]
+                   [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                   [arity (length (syntax->list (syntax (dom ...))))])
+       (values
+        (lambda (outer-args body)
+          (with-syntax ([body body]
+                        [(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [(name-dom-contract-x ...)
+                         (if method-proc?
+                             (cdr
+                              (syntax->list
+                               (syntax (dom-contract-x ...))))
+                             (syntax (dom-contract-x ...)))])
+            (syntax
+             (let ([dom-contract-x (coerce-contract '->d* dom)] 
+                   ...
+                   [dom-rest-contract-x (coerce-contract '->d* rest)])
+               (let ([dom-x (contract-proc dom-contract-x)] 
+                     ...
+                     [dom-rest-x (contract-proc dom-rest-contract-x)]
+                     [rng-mk-x rng-mk])
+                 (check-rng-procedure/more rng-mk-x arity)
+                 (let ([name-id (build-compound-type-name 
+                                 '->d*
+                                 (build-compound-type-name name-dom-contract-x ...)
+                                 dom-rest-contract-x
+                                 '(... ...))])
+                   body))))))
+        
+        ;; proj
+        (lambda (outer-args inner-lambda)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                        [inner-lambda inner-lambda])
+            (syntax
+             (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] 
+                   ...
+                   [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
+               inner-lambda))))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             (check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
+        (syntax (check-procedure/more? arity))
+        
+        (lambda (outer-args)
+          (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+            (syntax
+             ((arg-x ... . rest-arg-x)
+              (call-with-values
+               (lambda ()
+                 (apply rng-mk-x arg-x ... rest-arg-x))
+               (lambda rng-contracts
+                 (call-with-values
+                  (lambda ()
+                    (apply 
+                     val
+                     (dom-projection-x arg-x)
+                     ...
+                     (dom-rest-projection-x rest-arg-x)))
+                  (lambda results
+                    (check-rng-lengths results rng-contracts)
+                    (apply 
+                     values
+                     (map (lambda (rng-contract result)
+                            (((contract-proc (coerce-contract '->d* rng-contract))
+                              pos-blame
+                              neg-blame
+                              src-info
+                              orig-str)
+                             result))
+                          rng-contracts
+                          results))))))))))))]))
+
+;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->r/h method-proc? stx)
+  (syntax-case stx ()
+    [(_ ([x dom] ...) rng)
+     (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
+       [any 
+        (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))]
+       [(values . args)
+        (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))]
+       [rng
+        (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))]
+       [_
+        (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])]
+    
+    [(_ ([x dom] ...) rest-x rest-dom rng)
+     (syntax-case* (syntax rng) (values any) module-or-top-identifier=?
+       [any 
+        (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))]
+       [(values . whatever)
+        (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))]
+       [_
+        (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])]))
+
+;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx))
+
+;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->r-pp/h method-proc? name stx)
+  (syntax-case stx ()
+    [(_ ([x dom] ...) pre-expr . result-stuff)
+     (and (andmap identifier? (syntax->list (syntax (x ...))))
+          (not (check-duplicate-identifier (syntax->list (syntax (x ...))))))
+     (with-syntax ([stx-name name])
+       (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))]
+                     [arity (length (syntax->list (syntax (dom ...))))]
+                     [name-stx
+                      (with-syntax ([(name-xs ...) (if method-proc?
+                                                       (cdr (syntax->list (syntax (x ...))))
+                                                       (syntax (x ...)))])
+                        (syntax 
+                         (build-compound-type-name 'stx-name
+                                                   (build-compound-type-name
+                                                    (build-compound-type-name 'name-xs '(... ...))
+                                                    ...)
+                                                   '(... ...))))])
+         (values
+          (lambda (outer-args body)
+            (with-syntax ([body body]
+                          [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+              (syntax
+               (let ([name-id name-stx])
+                 body))))
+          (lambda (outer-args inner-lambda) inner-lambda)
+          
+          (lambda (outer-args)
+            (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                          [kind-of-thing (if method-proc? 'method 'procedure)])
+              (syntax
+               (begin 
+                 (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str)))))
+          
+          (syntax (check-procedure? arity))
+          
+          (lambda (outer-args)
+            (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+              (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=?
+                [(any)
+                 (syntax
+                  ((x ...)
+                   (begin
+                     (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                     (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                           ...)
+                       (val (dom-id x) ...)))))]
+                [((values (rng-ids rng-ctc) ...) post-expr)
+                 (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                      (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                 (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))])
+                   (syntax
+                    ((x ...)
+                     (begin
+                       (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                       (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                             ...)
+                         (let-values ([(rng-ids ...) (val (dom-id x) ...)])
+                           (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
+                           (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
+                                             pos-blame neg-blame src-info orig-str)] ...)
+                             (values (rng-ids-x rng-ids) ...))))))))]
+                [((values (rng-ids rng-ctc) ...) post-expr)
+                 (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                 (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))])
+                   (raise-syntax-error name "duplicate identifier" stx dup))]
+                [((values (rng-ids rng-ctc) ...) post-expr)
+                 (for-each (lambda (rng-id) 
+                             (unless (identifier? rng-id)
+                               (raise-syntax-error name "expected identifier" stx rng-id)))
+                           (syntax->list (syntax (rng-ids ...))))]
+                [((values . x) . junk)
+                 (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))]
+                [(rng res-id post-expr)
+                 (syntax
+                  ((x ...)
+                   (begin
+                     (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                     (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                           ...
+                           [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)])
+                       (let ([res-id (rng-id (val (dom-id x) ...))])
+                         (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
+                         res-id)))))]
+                [_ 
+                 (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
+    
+    [(_ ([x dom] ...) pre-expr . result-stuff)
+     (andmap identifier? (syntax->list (syntax (x ...))))
+     (raise-syntax-error 
+      name
+      "duplicate identifier"
+      stx
+      (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+    [(_ ([x dom] ...) pre-expr . result-stuff)
+     (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x)))
+               (syntax->list (syntax (x ...))))]
+    [(_ (x ...) pre-expr . result-stuff)
+     (for-each (lambda (x)
+                 (syntax-case x ()
+                   [(x y) (identifier? (syntax x)) (void)]
+                   [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))]))
+               (syntax->list (syntax (x ...))))]
+    [(_ x dom pre-expr . result-stuff)
+     (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
+
+;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx))
+
+;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
+(define (->r-pp-rest/h method-proc? name stx)
+  (syntax-case stx ()
+    [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
+     (and (identifier? (syntax rest-x))
+          (andmap identifier? (syntax->list (syntax (x ...))))
+          (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...)))))))
+     (with-syntax ([stx-name name])
+       (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))]
+                     [arity (length (syntax->list (syntax (dom ...))))]
+                     [name-stx 
+                      (with-syntax ([(name-xs ...) (if method-proc?
+                                                       (cdr (syntax->list (syntax (x ...))))
+                                                       (syntax (x ...)))])
+                        (syntax 
+                         (build-compound-type-name 'stx-name
+                                                   `(,(build-compound-type-name 'name-xs '(... ...)) ...)
+                                                   'rest-x
+                                                   '(... ...)
+                                                   '(... ...))))])
+         (values
+          (lambda (outer-args body)
+            (with-syntax ([body body]
+                          [(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+              (syntax
+               (let ([name-id name-stx])
+                 body))))
+          (lambda (outer-args inner-lambda) inner-lambda)
+          
+          (lambda (outer-args)
+            (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
+                          [kind-of-thing (if method-proc? 'method 'procedure)])
+              (syntax
+               (begin 
+                 (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str)))))
+          (syntax (check-procedure/more? arity))
+          
+          (lambda (outer-args)
+            (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
+              (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=?
+                [(any)
+                 (syntax
+                  ((x ... . rest-x)
+                   (begin
+                     (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                     (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                           ...
+                           [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)])
+                       (apply val (dom-id x) ... (rest-id rest-x))))))]
+                [(any . x)
+                 (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
+                [((values (rng-ids rng-ctc) ...) post-expr)
+                 (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                      (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                 (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))])
+                   (syntax
+                    ((x ... . rest-x)
+                     (begin
+                       (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                       (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                             ...
+                             [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)])
+                         (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
+                           (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
+                           (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
+                                             pos-blame neg-blame src-info orig-str)] ...)
+                             (values (rng-ids-x rng-ids) ...))))))))]
+                [((values (rng-ids rng-ctc) ...) . whatever)
+                 (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                      (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))))
+                 (raise-syntax-error name "expected exactly on post-expression at the end" stx)]
+                [((values (rng-ids rng-ctc) ...) . whatever)
+                 (andmap identifier? (syntax->list (syntax (rng-ids ...))))
+                 (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))])
+                   (raise-syntax-error name "duplicate identifier" stx dup))]
+                [((values (rng-ids rng-ctc) ...) . whatever)
+                 (for-each (lambda (rng-id) 
+                             (unless (identifier? rng-id)
+                               (raise-syntax-error name "expected identifier" stx rng-id)))
+                           (syntax->list (syntax (rng-ids ...))))]
+                [((values . x) . whatever)
+                 (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))]
+                [(rng res-id post-expr)
+                 (identifier? (syntax res-id))
+                 (syntax
+                  ((x ... . rest-x)
+                   (begin
+                     (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
+                     (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
+                           ...
+                           [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]
+                           [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)])
+                       (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
+                         (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
+                         res-id)))))]
+                [(rng res-id post-expr)
+                 (not (identifier? (syntax res-id)))
+                 (raise-syntax-error name "expected an identifier" stx (syntax res-id))]
+                [_
+                 (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))]
+    [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
+     (not (identifier? (syntax rest-x)))
+     (raise-syntax-error name "expected identifier" stx (syntax rest-x))]
+    [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff)
+     (and (identifier? (syntax rest-x))
+          (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...))))))
+     (raise-syntax-error 
+      name
+      "duplicate identifier"
+      stx
+      (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+    
+    [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff)
+     (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x)))
+               (cons
+                (syntax rest-x)
+                (syntax->list (syntax (x ...)))))]
+    [(_ x dom rest-x rest-dom rng . result-stuff)
+     (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
+
+;; set-inferred-name-from : syntax syntax -> syntax
+(define (set-inferred-name-from with-name to-be-named)
+  (let ([name (syntax-local-infer-name with-name)])
+    (cond
+      [(identifier? name)
+       (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))]
+                     [name (syntax-e name)])
+         (syntax (let ([name rhs]) name)))]
+      [(symbol? name)
+       (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)]
+                     [name name])
+         (syntax (let ([name rhs]) name)))]
+      [else to-be-named])))
+
+;; generate-indicies : syntax[list] -> (cons number (listof number))
+;; given a syntax list of length `n', returns a list containing
+;; the number n followed by th numbers from 0 to n-1
+(define (generate-indicies stx)
+  (let ([n (length (syntax->list stx))])
+    (cons n
+          (let loop ([i n])
+            (cond
+              [(zero? i) null]
+              [else (cons (- n i)
+                          (loop (- i 1)))])))))
\ No newline at end of file
diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss
index ee60620468..e1f0551789 100644
--- a/collects/mzlib/private/contract-arrow.ss
+++ b/collects/mzlib/private/contract-arrow.ss
@@ -1,12 +1,12 @@
 #lang scheme/base
 
 (require scheme/private/contract-guts
-         scheme/private/contract-arr-checks
-         scheme/private/contract-opt)
+         scheme/private/contract-opt
+         "contract-arr-checks.ss")
 (require (for-syntax scheme/base)
          (for-syntax scheme/private/contract-opt-guts)
          (for-syntax scheme/private/contract-helpers)
-         (for-syntax scheme/private/contract-arr-obj-helpers)
+         (for-syntax "contract-arr-obj-helpers.ss")
          (for-syntax syntax/stx)
          (for-syntax syntax/name))
 
diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss
index 15cf8e523d..4de48a079c 100644
--- a/collects/mzlib/private/contract-object.ss
+++ b/collects/mzlib/private/contract-object.ss
@@ -2,11 +2,11 @@
 (require "contract-arrow.ss"
          scheme/private/contract-guts
          scheme/private/class-internal
-         scheme/private/contract-arr-checks)
+         "contract-arr-checks.ss")
 
 (require (for-syntax scheme/base
                      scheme/private/contract-helpers
-                     scheme/private/contract-arr-obj-helpers))
+                     "contract-arr-obj-helpers.ss"))
 
 (provide mixin-contract
          make-mixin-contract
diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss
index fb60c36b1d..ebe59555fa 100644
--- a/collects/scheme/private/contract-arrow.ss
+++ b/collects/scheme/private/contract-arrow.ss
@@ -10,9 +10,17 @@ v4 done:
 v4 todo:
 
 - rewrite ->d
+  - to test:
+    ->d first-order
+
+- rewrite case->
+
+- rewrite object-contract to use new function combinators.
 
 - remove opt-> opt->* ->pp ->pp-rest ->r ->d*
 
+- change mzlib/contract to rewrite into scheme/contract (maybe?)
+
 - raise-syntax-errors
   . multiple identical keywords syntax error, sort-keywords
   . split-doms
@@ -30,16 +38,10 @@ v4 todo:
          (for-syntax syntax/name))
 
 (provide ->
-         ->d
          ->*
-         ->d*
-         ->r
-         ->pp
-         ->pp-rest
-         case->
-         opt->
-         opt->*
-         unconstrained-domain->)
+         ->d
+         unconstrained-domain->
+         the-unsupplied-arg)
 
 (define-syntax (unconstrained-domain-> stx)
   (syntax-case stx ()
@@ -66,6 +68,23 @@ v4 todo:
                                               "expected a procedure")))))
               procedure?))))]))
 
+
+;              
+;              
+;              
+;         ;    
+;          ;   
+;           ;  
+;   ;;;;;;;;;; 
+;           ;  
+;          ;   
+;         ;    
+;              
+;              
+;              
+;              
+
+
 (define (build--> name
                   doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 
                   mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
@@ -170,7 +189,10 @@ v4 todo:
      (let ([range
             (cond
               [rng-any? 'any]
-              [else (apply build-compound-type-name rngs)])])
+              [(and (pair? rngs)
+                    (null? (cdr rngs)))
+               (car rngs)]
+              [else (apply build-compound-type-name 'values rngs)])])
        (apply
         build-compound-type-name 
         '->*
@@ -216,6 +238,10 @@ v4 todo:
       [(null? pairs) null]
       [else (insert (car pairs) (loop (cdr pairs)))])))
 
+;; split-doms : syntax identifier syntax -> syntax
+;; given a sequence of keywords interpersed with other
+;; stuff, splits out the keywords and sorts them,
+;; and leaves the rest of the stuff in a row.
 (define-for-syntax (split-doms stx name raw-doms)
   (let loop ([raw-doms raw-doms]
              [doms '()]
@@ -233,13 +259,13 @@ v4 todo:
        (and (keyword? (syntax-e #'kwd))
             (keyword? (syntax-e #'arg)))
        (raise-syntax-error name
-                           "expected a keyword followed by a contract"
+                           "cannot have two keywords in a row"
                            stx
                            #'kwd)]
       [(kwd)
        (keyword? (syntax-e #'kwd))
        (raise-syntax-error name
-                           "expected a keyword to be followed by a contract"
+                           "cannot have a keyword at the end"
                            stx
                            #'kwd)]
       [(x . rest)
@@ -329,139 +355,6 @@ v4 todo:
   (let-values ([(stx _1 _2) (->/proc/main stx)])
     stx))
 
-(define unspecified-dom (gensym 'unspecified-keyword))
-
-;; check-duplicate-kwds : syntax (listof syntax[keyword]) -> void
-(define-for-syntax (check-duplicate-kwds stx kwds)
-  (let loop ([kwds kwds])
-    (unless (null? kwds)
-      (when (member (syntax-e (car kwds)) (map syntax-e (cdr kwds)))
-        (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))
-
-;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
-(define-for-syntax (->*/proc/main stx)
-  (syntax-case* stx (->* any) module-or-top-identifier=?
-    [(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst)
-     (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
-                    (split-doms stx '->* #'(raw-mandatory-dom ...))]
-                   [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
-                    (split-doms stx '->* #'(raw-optional-dom ...))])
-       ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...)))
-       (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))]
-                     [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))]
-                     [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
-                     [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
-                     
-                     [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))]
-                     [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))]
-                     [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))]
-                     [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
-         (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append 
-                                                               (map list
-                                                                    (syntax->list #'(mandatory-dom-kwd ...)) 
-                                                                    (syntax->list #'(mandatory-dom-kwd-arg ...))))]
-                       [(optional-dom-kwd/var-seq ...) (apply append 
-                                                              (map list 
-                                                                   (syntax->list #'(optional-dom-kwd ...)) 
-                                                                   (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
-                       [(mandatory-dom-kwd-proj-apps ...) (apply append 
-                                                                 (map list
-                                                                      (syntax->list #'(mandatory-dom-kwd ...)) 
-                                                                      (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))]
-                       [((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) 
-                        (sort-keywords stx (syntax->list
-                                            #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ...
-                                               (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))])
-           (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...)
-                          (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))]
-                         [(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))]
-                         [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
-             
-             
-             (let-values ([(rest-ctc rng-ctc)
-                           ;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
-                           ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
-                           (syntax-case #'rst (any)
-                             [(any) (values #f #f)]
-                             [(rest-expr any) (values #'rest-expr #f)]
-                             [((res-ctc ...)) (values #f #'(res-ctc ...))]
-                             [(rest-expr (res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
-                             [_ (raise-syntax-error #f "bad syntax" stx)])])
-               (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
-                             [(rng ...) (generate-temporaries (or rng-ctc '()))])
-                 #`(build-->
-                    '->*
-                    (list mandatory-dom ...)
-                    (list optional-dom ...)
-                    #,rest-ctc
-                    (list mandatory-dom-kwd-ctc ...)
-                    '(mandatory-dom-kwd ...)
-                    (list optional-dom-kwd-ctc ...)
-                    '(optional-dom-kwd ...)
-                    #,(if rng-ctc
-                          (with-syntax ([(rng-ctc ...) rng-ctc])
-                            #'(list rng-ctc ...))
-                          #''())
-                    #,(if rng-ctc #f #t)
-                    (λ (chk mandatory-dom-proj ...  
-                            #,@(if rest-ctc
-                                   #'(rest-proj)
-                                   #'())
-                            optional-dom-proj ... 
-                            mandatory-dom-kwd-proj ... 
-                            optional-dom-kwd-proj ... 
-                            rng-proj ...)
-                      (λ (f)
-                        (chk f)
-                        #,(add-name-prop
-                           (syntax-local-infer-name stx)
-                           #`(λ (mandatory-dom-arg ... 
-                                 [optional-dom-arg unspecified-dom] ... 
-                                 mandatory-dom-kwd/var-seq ... 
-                                 optional-dom-kwd/var-seq ...
-                                 #,@(if rest-ctc #'rest #'()))
-                               (let*-values ([(kwds kwd-args) (values '() '())]
-                                             [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
-                                                                  (values kwds kwd-args)
-                                                                  (values (cons 'rev-sorted-dom-kwd kwds)
-                                                                          (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
-                                                                                kwd-args)))] 
-                                             ...
-                                             [(opt-args) #,(if rest-ctc 
-                                                               #'(rest-proj rest)
-                                                               #''())]
-                                             [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
-                                                             opt-args
-                                                             (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
-                                             ...)
-                                 #,(let ([call #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args)])
-                                     (if rng-ctc
-                                         #`(let-values ([(rng ...) #,call])
-                                             (values (rng-proj rng) ...))
-                                         call))))))))))))))]))
-           
-(define-syntax (->* stx) (->*/proc/main stx))
-
-(define-for-syntax (select/h stx err-name ctxt-stx)
-  (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
-    [(-> . args) ->/h]
-    [(->* . args) ->*/h]
-    [(->d . args) ->d/h]
-    [(->d* . args) ->d*/h]
-    [(->r . args) ->r/h]
-    [(->pp . args) ->pp/h]
-    [(->pp-rest . args) ->pp-rest/h]
-    [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
-    [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
-
-(define-syntax (->d stx) (make-/proc #f ->d/h stx))
-(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
-(define-syntax (->r stx) (make-/proc #f ->r/h stx))
-(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
-(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
-(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
-(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
-(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
 
 ;;
 ;; arrow opter
@@ -607,3 +500,477 @@ v4 todo:
          (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
          (opt/arrow-ctc (syntax->list (syntax (dom ...)))
                         (list #'rng)))]))
+
+
+
+;                     
+;                     
+;                     
+;         ;       ;   
+;          ;      ;   
+;           ;   ;;;;; 
+;   ;;;;;;;;;;   ;;   
+;           ;    ; ;  
+;          ;          
+;         ;           
+;                     
+;                     
+;                     
+;                     
+
+
+(define unspecified-dom (gensym 'unspecified-keyword))
+
+;; check-duplicate-kwds : syntax (listof syntax[keyword]) -> void
+(define-for-syntax (check-duplicate-kwds stx kwds)
+  (let loop ([kwds kwds])
+    (unless (null? kwds)
+      (when (member (syntax-e (car kwds)) (map syntax-e (cdr kwds)))
+        (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))
+
+;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
+(define-for-syntax (->*/proc/main stx)
+  (syntax-case* stx (->* any) module-or-top-identifier=?
+    [(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst)
+     (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
+                    (split-doms stx '->* #'(raw-mandatory-dom ...))]
+                   [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
+                    (split-doms stx '->* #'(raw-optional-dom ...))])
+       ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...)))
+       (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))]
+                     [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))]
+                     [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
+                     [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
+                     
+                     [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))]
+                     [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))]
+                     [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))]
+                     [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
+         (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append 
+                                                               (map list
+                                                                    (syntax->list #'(mandatory-dom-kwd ...)) 
+                                                                    (syntax->list #'(mandatory-dom-kwd-arg ...))))]
+                       [(optional-dom-kwd/var-seq ...) (apply append 
+                                                              (map list 
+                                                                   (syntax->list #'(optional-dom-kwd ...)) 
+                                                                   (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
+                       [(mandatory-dom-kwd-proj-apps ...) (apply append 
+                                                                 (map list
+                                                                      (syntax->list #'(mandatory-dom-kwd ...)) 
+                                                                      (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))]
+                       [((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) 
+                        (sort-keywords stx (syntax->list
+                                            #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ...
+                                               (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))])
+           (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...)
+                          (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))]
+                         [(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))]
+                         [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
+             
+             
+             (let-values ([(rest-ctc rng-ctc)
+                           ;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
+                           ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
+                           (syntax-case #'rst (any values)
+                             [(any) (values #f #f)]
+                             [(rest-expr any) (values #'rest-expr #f)]
+                             [((values res-ctc ...)) (values #f #'(res-ctc ...))]
+                             [(rest-expr (values res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
+                             [(res-ctc) (values #f #'(res-ctc))]
+                             [(rest-expr res-ctc) (values #'rest-expr #'(res-ctc))]
+                             [_ (raise-syntax-error #f "bad syntax" stx)])])
+               (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
+                             [(rng ...) (generate-temporaries (or rng-ctc '()))])
+                 #`(build-->
+                    '->*
+                    (list mandatory-dom ...)
+                    (list optional-dom ...)
+                    #,rest-ctc
+                    (list mandatory-dom-kwd-ctc ...)
+                    '(mandatory-dom-kwd ...)
+                    (list optional-dom-kwd-ctc ...)
+                    '(optional-dom-kwd ...)
+                    #,(if rng-ctc
+                          (with-syntax ([(rng-ctc ...) rng-ctc])
+                            #'(list rng-ctc ...))
+                          #''())
+                    #,(if rng-ctc #f #t)
+                    (λ (chk mandatory-dom-proj ...  
+                            #,@(if rest-ctc
+                                   #'(rest-proj)
+                                   #'())
+                            optional-dom-proj ... 
+                            mandatory-dom-kwd-proj ... 
+                            optional-dom-kwd-proj ... 
+                            rng-proj ...)
+                      (λ (f)
+                        (chk f)
+                        #,(add-name-prop
+                           (syntax-local-infer-name stx)
+                           #`(λ (mandatory-dom-arg ... 
+                                 [optional-dom-arg unspecified-dom] ... 
+                                 mandatory-dom-kwd/var-seq ... 
+                                 optional-dom-kwd/var-seq ...
+                                 #,@(if rest-ctc #'rest #'()))
+                               (let*-values ([(kwds kwd-args) (values '() '())]
+                                             [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
+                                                                  (values kwds kwd-args)
+                                                                  (values (cons 'rev-sorted-dom-kwd kwds)
+                                                                          (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
+                                                                                kwd-args)))] 
+                                             ...
+                                             [(opt-args) #,(if rest-ctc 
+                                                               #'(rest-proj rest)
+                                                               #''())]
+                                             [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
+                                                             opt-args
+                                                             (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
+                                             ...)
+                                 #,(let ([call (if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
+                                                   #'(apply f (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
+                                                   #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
+                                     (if rng-ctc
+                                         #`(let-values ([(rng ...) #,call])
+                                             (values (rng-proj rng) ...))
+                                         call))))))))))))))]))
+           
+(define-syntax (->* stx) (->*/proc/main stx))
+
+
+
+;                     
+;                     
+;                     
+;         ;       ;;; 
+;          ;       ;; 
+;           ;      ;; 
+;   ;;;;;;;;;;  ;;;;; 
+;           ;  ;;  ;; 
+;          ;   ;;  ;; 
+;         ;    ;;  ;; 
+;               ;;;;;;
+;                     
+;                     
+;                     
+
+;; parses everything after the mandatory and optional doms in a ->d contract
+(define-for-syntax (parse-leftover stx leftover)
+  (let*-values ([(id/rest-id leftover) 
+                 (syntax-case leftover ()
+                   [(id rest-expr . leftover)
+                    (and (identifier? #'id)
+                         (not (keyword? (syntax-e #'rest-expr))))
+                    (values #'(id rest-expr) #'leftover)]
+                   [_ (values #f leftover)])]
+                [(pre-cond leftover)
+                 (syntax-case leftover ()
+                   [(#:pre-cond pre-cond . leftover)
+                    (values #'pre-cond #'leftover)]
+                   [_ (values #f leftover)])]
+                [(range leftover) 
+                 (syntax-case leftover ()
+                   [(range . leftover) (values #'range #'leftover)]
+                   [_
+                    (raise-syntax-error #f "bad syntax" stx)])]
+                [(post-cond leftover) 
+                 (syntax-case leftover ()
+                   [(#:post-cond post-cond . leftover)
+                    (values #'post-cond #'leftover)]
+                   [_ (values #f leftover)])])
+    (syntax-case leftover ()
+      [() 
+       (values id/rest-id pre-cond range post-cond)]
+      [_ 
+       (raise-syntax-error #f "bad syntax" stx)])))
+
+;; verify-->d-structure : syntax syntax -> syntax
+;; returns the second argument when it has the proper shape for the first two arguments to ->d*
+;; otherwise, raises a syntax error.
+(define-for-syntax (verify-->d-structure stx doms)
+  (syntax-case doms ()
+    [((regular ...) (kwd ...))
+     (let ([check-pair-shape
+            (λ (reg)
+              (syntax-case reg ()
+                [(id dom)
+                 (identifier? #'id)
+                 (void)]
+                [(a b)
+                 (raise-syntax-error #f "expected an identifier" stx #'a)]
+                [_
+                 (raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
+       (for-each check-pair-shape (syntax->list #'(regular ...)))
+       (for-each
+        (λ (kwd)
+          (syntax-case kwd ()
+            [(kwd ps)
+             (check-pair-shape #'ps)]))
+        (syntax->list #'(kwd ...))))])
+  doms)
+
+(define-syntax (->d stx)
+  (syntax-case stx ()
+    [(_ (raw-mandatory-doms ...)
+        (raw-optional-doms ...)
+        .
+        leftover)
+     (with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...)) 
+                    (verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
+                   [(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
+                    (verify-->d-structure stx (split-doms stx '->d #'(raw-optional-doms ...)))])
+       (with-syntax ([((kwd kwd-id) ...)
+                      (sort-keywords 
+                       stx
+                       (syntax->list
+                        #'((optional-kwd optional-kwd-id) ...
+                           (mandatory-kwd mandatory-kwd-id) ...)))])
+         (let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
+           (with-syntax ([(dom-params ...)
+                          #`(mandatory-regular-id ... 
+                             optional-regular-id ... 
+                             #,@(if id/rest 
+                                    (with-syntax ([(id rst-ctc) id/rest])
+                                      #'(id))
+                                    #'())
+                             kwd-id ...)])
+             (with-syntax ([((rng-params ...) rng-ctcs)
+                            (syntax-case range (any values)
+                              [(values [id ctc] ...) #'((id ...) (ctc ...))]
+                              [(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)]
+                              [any #'(() #f)]
+                              [[id ctc] #'((id) (ctc))]
+                              [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])])
+               (let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))])
+                 (when dup
+                   (raise-syntax-error #f "duplicate identifier" stx dup)))
+               #`(build-->d (list (λ (dom-params ...) mandatory-doms) ...)
+                            (list (λ (dom-params ...) optional-doms) ...)
+                            (list (λ (dom-params ...) mandatory-kwd-dom) ...)
+                            (list (λ (dom-params ...) optional-kwd-dom) ...)
+                            #,(if id/rest 
+                                  (with-syntax ([(id rst-ctc) id/rest])
+                                    #`(λ (dom-params ...) rst-ctc))
+                                  #f)
+                            #,(if pre-cond
+                                  #`(λ (dom-params ...) #,pre-cond)
+                                  #f)
+                            #,(syntax-case #'rng-ctcs ()
+                                [#f #f]
+                                [(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)])
+                            #,(if post-cond
+                                  #`(λ (rng-params ... dom-params ...) #,post-cond)
+                                  #f)
+                            '(mandatory-kwd ...)
+                            '(optional-kwd ...)
+                            (λ (f) 
+                              #,(add-name-prop
+                                 (syntax-local-infer-name stx)
+                                 #`(λ args (apply f args))))))))))]))
+
+(define (->d-proj ->d-stct)
+  (let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
+                              (length (->d-optional-dom-ctcs ->d-stct)))])
+    (λ (pos-blame neg-blame src-info orig-str)
+      (λ (val)
+        (check-procedure val
+                         (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
+                         (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
+                         (->d-mandatory-keywords ->d-stct)
+                         (->d-optional-keywords ->d-stct)
+                         src-info pos-blame orig-str)
+        (let ([kwd-proc
+               (λ (kwd-args kwd-arg-vals . orig-args)
+                 (let* ([dep-pre-args
+                         (build-dep-ctc-args non-kwd-ctc-count orig-args (->d-rest-ctc ->d-stct)
+                                             (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
+                        [thnk
+                         (λ ()
+                           (when (->d-pre-cond ->d-stct)
+                             (unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
+                               (raise-contract-error val
+                                                     src-info
+                                                     neg-blame
+                                                     orig-str
+                                                     "#:pre-cond violation")))
+                           (keyword-apply
+                            val
+                            kwd-args
+                            
+                            ;; contracted keyword arguments
+                            (let loop ([all-kwds (->d-keywords ->d-stct)]
+                                       [kwd-ctcs (->d-keyword-ctcs ->d-stct)] 
+                                       [building-kwd-args kwd-args]
+                                       [building-kwd-arg-vals kwd-arg-vals])
+                              (cond
+                                [(or (null? building-kwd-args) (null? all-kwds)) '()]
+                                [else (if (eq? (car all-kwds)
+                                               (car building-kwd-args))
+                                          (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str)
+                                                (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
+                                          (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
+                            
+                            ;; contracted ordinary arguments
+                            (let loop ([args orig-args]
+                                       [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
+                                                             (->d-optional-dom-ctcs ->d-stct))])
+                              (cond
+                                [(null? args) 
+                                 (if (->d-rest-ctc ->d-stct)
+                                     (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
+                                     '())]
+                                [(null? non-kwd-ctcs) 
+                                 (if (->d-rest-ctc ->d-stct)
+                                     (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
+                                     
+                                     ;; ran out of arguments, but don't have a rest parameter.
+                                     ;; procedure-reduce-arity (or whatever the new thing is
+                                     ;; going to be called) should ensure this doesn't happen.
+                                     (error 'shouldnt\ happen))]
+                                [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
+                                            (loop (cdr args)
+                                                  (cdr non-kwd-ctcs)))]))))])
+                   (if (->d-range ->d-stct)
+                       (call-with-values
+                        thnk
+                        (λ orig-results
+                          (let* ([range-count (length (->d-range ->d-stct))]
+                                 [post-args (append orig-results orig-args)]
+                                 [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
+                                 [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count post-args (->d-rest-ctc ->d-stct)
+                                                                    (->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
+                            (when (->d-post-cond ->d-stct)
+                              (unless (apply (->d-post-cond ->d-stct) dep-post-args)
+                                (raise-contract-error val
+                                                      src-info
+                                                      pos-blame
+                                                      orig-str
+                                                      "#:post-cond violation")))
+                            
+                            (unless (= range-count (length orig-results))
+                              (raise-contract-error val
+                                                    src-info
+                                                    pos-blame
+                                                    orig-str
+                                                    "expected ~a results, got ~a"
+                                                    range-count
+                                                    (length orig-results)))
+                            (apply
+                             values
+                             (let loop ([results orig-results]
+                                        [result-contracts (->d-range ->d-stct)])
+                               (cond
+                                 [(null? result-contracts) '()]
+                                 [else
+                                  (cons (invoke-dep-ctc (car result-contracts) dep-post-args (car results) pos-blame neg-blame src-info orig-str)
+                                        (loop (cdr results) (cdr result-contracts)))]))))))
+                       (thnk))))])
+        (make-keyword-procedure kwd-proc
+                                ((->d-name-wrapper ->d-stct)
+                                 (λ args
+                                   (apply kwd-proc '() '() args)))))))))
+
+;; invoke-dep-ctc : (...? -> ctc) (listof tst) val pos-blame neg-blame src-info orig-src -> tst
+(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str)
+  (let ([ctc (coerce-contract '->d (apply dep-ctc dep-args))]) 
+    ((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str) val)))
+
+;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
+(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
+  (append 
+   
+   ;; ordinary args
+   (let loop ([count non-kwd-ctc-count]
+              [args args])
+     (cond
+       [(zero? count) 
+        (if rest-arg?
+            (list args)
+            '())]
+       [(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
+       [else (cons (car args) (loop (- count 1) (cdr args)))]))
+   
+   ;; kwd args
+   (let loop ([all-kwds all-kwds]
+              [kwds supplied-kwds]
+              [args supplied-args])
+     (cond
+       [(null? all-kwds) null]
+       [else (let* ([kwd (car all-kwds)]
+                    [kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
+               (if kwd-matches?
+                   (cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
+                   (cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
+
+(define-struct unsupplied-arg ())
+(define the-unsupplied-arg (make-unsupplied-arg))
+
+(define (build-->d mandatory-dom-ctcs optional-dom-ctcs
+                   mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
+                   rest-ctc pre-cond range post-cond
+                   mandatory-kwds optional-kwds
+                   name-wrapper)
+  (let ([kwd/ctc-pairs (sort
+                        (map cons 
+                             (append mandatory-kwds optional-kwds)
+                             (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
+                        (λ (x y) (keyword<? (car x) (car y))))])
+    (make-->d mandatory-dom-ctcs optional-dom-ctcs
+              (map cdr kwd/ctc-pairs)
+              rest-ctc pre-cond range post-cond
+              (map car kwd/ctc-pairs)
+              mandatory-kwds
+              optional-kwds
+              name-wrapper)))
+
+(define-struct/prop ->d (mandatory-dom-ctcs  ;; (listof (-> ??? ctc))
+                         optional-dom-ctcs   ;; (listof (-> ??? ctc))
+                         keyword-ctcs        ;; (listof (-> ??? ctc))
+                         rest-ctc            ;; (or/c false/c (-> ??? ctc))
+                         pre-cond            ;; (-> ??? boolean)
+                         range               ;; (or/c false/c (-> ??? ctc))
+                         post-cond           ;; (-> ??? boolean)
+                         keywords            ;; (listof keywords) -- sorted by keyword<
+                         mandatory-keywords  ;; (listof keywords) -- sorted by keyword<
+                         optional-keywords   ;; (listof keywords) -- sorted by keyword<
+                         name-wrapper)       ;; (-> proc proc) 
+  ((proj-prop ->d-proj)
+   (name-prop (λ (ctc) 
+                (let* ([counting-id 'x]
+                       [ids '(x y z w)]
+                       [next-id
+                        (λ ()
+                          (cond
+                            [(pair? ids)
+                             (begin0 (car ids)
+                                     (set! ids (cdr ids)))]
+                            [(null? ids)
+                             (begin0 
+                               (string->symbol (format "~a0" counting-id))
+                               (set! ids 1))]
+                            [else
+                             (begin0 
+                               (string->symbol (format "~a~a" counting-id ids))
+                               (set! ids (+ ids 1)))]))])
+                  `(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
+                         ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
+                        (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
+                         ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
+                        ,@(if (->d-rest-ctc ctc)
+                              (list (next-id) '...)
+                              '())
+                        ,@(if (->d-pre-cond ctc)
+                              (list '#:pre-cond '...)
+                              (list))
+                        ,(let ([range (->d-range ctc)])
+                           (cond
+                             [(not range) 'any]
+                             [(and (not (null? range))
+                                  (null? (cdr range)))
+                              `[,(next-id) ...]]
+                            [else
+                             `(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
+                        ,@(if (->d-post-cond ctc)
+                              (list '#:post-cond '...)
+                              (list))))))
+   (first-order-prop (λ (ctc) (λ (x) #f)))
+   (stronger-prop (λ (this that) (eq? this that)))))
diff --git a/collects/scheme/private/contract-object.ss b/collects/scheme/private/contract-object.ss
index a8aa0760ae..47a47aaddc 100644
--- a/collects/scheme/private/contract-object.ss
+++ b/collects/scheme/private/contract-object.ss
@@ -398,10 +398,12 @@
                         "expected an object with field ~s"
                         field-name))
 
+(define-syntax (old->d stx) (make-/proc #f ->d/h stx)) ;; just here for now so the mixin contracts work.
+
 (define (make-mixin-contract . %/<%>s)
   ((and/c (flat-contract class?)
           (apply and/c (map sub/impl?/c %/<%>s)))
-   . ->d .
+   . old->d .
    subclass?/c))
 
 (define (subclass?/c %)
@@ -440,4 +442,4 @@
        [else `(is-a?/c unknown<%>)])
      (lambda (x) (is-a? x <%>)))))
 
-(define mixin-contract (class? . ->d . subclass?/c))
+(define mixin-contract (class? . old->d . subclass?/c))
diff --git a/collects/scribblings/framework/info.ss b/collects/scribblings/framework/info.ss
new file mode 100644
index 0000000000..a2a5d61089
--- /dev/null
+++ b/collects/scribblings/framework/info.ss
@@ -0,0 +1,3 @@
+(module info setup/infotab
+  (define name "Scribblings: Framework")
+  (define scribblings '(("framework.scrbl" (#;multi-page main-doc)))))
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 8314115863..9d53f4b221 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -295,13 +295,25 @@ error.}
 @section{Function Contracts}
 
 A @deftech{function contract} wraps a procedure to delay
-checks for its arguments and results.
+checks for its arguments and results. There are three
+primary function contract combinators that have increasing
+amounts of expressiveness and increasing additional
+overheads. The first @scheme[->] is the cheapest. It
+generates wrapper functions that can call the original
+function directly. Contracts built with @scheme[->*] require
+packaging up arguments as lists in the wrapper function and
+then using either @scheme[keyword-apply] or
+@scheme[apply]. Finally, @scheme[->d] is the most expensive,
+because it requires delaying the evaluation of the contract
+expressions for the domain and range until the function
+itself is called or returns.
+
+The @scheme[case->] contract ...
 
 @defform*/subs[#:literals (any values)
-               [(-> dom ... range-expr)
-                (-> dom ... (values range-expr ...))
-                (-> dom ... any)]
-               ([dom dom-expr (code:line keyword dom-expr)])]{
+               [(-> dom ... range)]
+               ([dom dom-expr (code:line keyword dom-expr)]
+                [range range-expr (values range-expr ...) any])]{
 
 Produces a contract for a function that accepts a fixed
 number of arguments and returns either a fixed number of
@@ -351,7 +363,7 @@ each values must match its respective contract.}
            (->* (mandatory-dom ...) (optional-dom ...) range)]
           ([mandatory-dom dom-expr (code:line keyword dom-expr)]
            [optional-dom dom-expr (code:line keyword dom-expr)]
-           [range (range-expr ...) any])]{
+           [range range-expr (values range-expr ...) any])]{
 
 The @scheme[->*] contract combinator produces contracts for
 functions that accept optional arguments (either keyword or
@@ -373,148 +385,57 @@ symbols, and that return a symbol.
 
 }
 
-
-@defform*/subs[#:literals (any)
+@defform*/subs[#:literals (any values)
 [(->d (mandatory-dependent-dom ...) 
       (optional-dependent-dom ...) 
-      pre-cond range post-cond)
- (->d (mandatory-dependent-dom ...) 
-      (optional-dependent-dom ...) 
-      id rest-expr
-      pre-cond range post-cond)]
+      rest
+      pre-cond
+      dep-range)]
 ([mandatory-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
  [optional-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])]
+ [rest (code:line) (code:line id rest-expr)]
  [pre-cond (code:line) (code:line #:pre-cond boolean-expr)]
+ [dep-range any
+            (code:line [id range-expr] post-cond)
+            (code:line (values [id range-expr] ...) post-cond)]
  [post-cond (code:line) (code:line #:post-cond boolean-expr)]
- [range (range-expr ...) any])]{
-Not yet implemented.
+)]{
+
+The @scheme[->d] is similar in shape to @scheme[->*], with
+two extensions: names have been added to each argument and
+result, which allows the contracts to depend on the values
+of the arguments and results, and pre- and post-condition
+expressions have been added in order to express contracts
+that are not naturally tied to a particular argument or
+result.
+
+The first two subforms of a @scheme[->d] contract cover the
+mandatory and optional arguments. Following that is an
+optional rest-args contract, and an optional
+pre-condition. The @scheme[dep-range] non-terminal covers
+the possible post-condition contracts. If it is
+@scheme[any], then any result (or results) are
+allowed. Otherwise, the result contract can be a name and a
+result contract, or a multiple values return and, in either
+of the last two cases, it may be optionally followed by a
+post-condition.
+
+Each of the @scheme[id]s on an argument (including the rest
+argument) is visible in all of the sub-expressions of
+@scheme[->d]. Each of the @scheme[id]s on a result is
+visible in the subexpressions of the @scheme[dep-range].
 }
 
 @;{
-@defform[(->d expr ... res-gen-expr)]{
-
-Like @scheme[->], but instead of a @scheme[_res-expr] to produce a
-result contract, @scheme[res-gen-expr] should produce a function
-that accepts that arguments and returns as many contracts as the
-function should produce values; each contract is associated with the
-corresponding result.
-
-For example, the following contract is satisfied by @scheme[sqrt] when
-@scheme[sqrt] is applied to small numbers:
-
-@schemeblock[
-(number?
- . ->d .
- (lambda (in)
-   (lambda (out)
-     (and (number? out)
-          (< (abs (- (* out out) in)) 0.01)))))
-]
-
-This contract says that the input must be a number and that the
-difference between the square of the result and the original number is
-less than @scheme[0.01].}
-
-@defform*[[(->d* (expr ...) expr res-gen-expr)
-           (->d* (expr ...) res-gen-expr)]]{
-
-Like @scheme[->*], but with @scheme[res-gen-expr] like @scheme[->d].}
-
-
-@defform*[#:literals (any values)
-          [(->r ([id expr] ...) res-expr)
-           (->r ([id expr] ...) any)
-           (->r ([id expr] ...) (values [res-id res-expr] ...))
-           (->r ([id expr] ...) id rest-expr res-expr)
-           (->r ([id expr] ...) id rest-expr any)
-           (->r ([id expr] ...) id rest-expr (values [res-id res-expr] ...))]]{
-              
-
-Produces a contract where allowed arguments to a function may all
-depend on each other, and where the allowed result of the function may
-depend on all of the arguments. The cases with a @scheme[rest-expr]
-are analogous to @scheme[->*] to support rest arguments.
-
-Each of the @scheme[id]s names one of the actual arguments to the
-function with the contract, an each @scheme[id] is bound in all
-@scheme[expr]s, the @scheme[res-expr] (if supplied), and
-@scheme[res-expr]s (if supplied). An @scheme[any] result
-specification is treated as in @scheme[->]. A @scheme[values] result
-specification indicates multiple result values, each with the
-corresponding contract; the @scheme[res-id]s are bound only in the
-@scheme[res-expr]s to the corresponding results.
-
-For example, the following contract specifies a function that accepts
-three arguments where the second argument and the result must both be
-between the first:
-
-@schemeblock[
-(->r ([x number?] [y (and/c (>=/c x) (<=/c z))] [z number?])
-     (and/c number? (>=/c x) (<=/c z)))
-]
-
-The contract
-
-@schemeblock[
-(->r () (values [x number?]
-                [y (and/c (>=/c x) (<=/c z))]
-                [z number?]))
-]
-
-matches a function that accepts no arguments and that returns three
-numeric values that are in ascending order.}
-
-
-@defform*[[(->pp ([id expr] ...) pre-expr expr res-id post-expr)
-           (->pp ([id expr] ...) pre-expr any)
-           (->pp ([id expr] ...) pre-expr (values [id expr] ...) post-expr)]]{
-
-Generalizes @scheme[->r] (without ``rest'' arguments) to support pre-
-and post-condition expression. The @scheme[id]s are bound in
-@scheme[pre-expr] and @scheme[post-expr], and @scheme[res-id] (if
-specified) corresponds to the result value and is bound in
-@scheme[post-id].
-
-If @scheme[pre-expr] evaluates to @scheme[#f], the caller is blamed.
-If @scheme[post-expr] evaluates to @scheme[#f], the function itself is
-blamed.}
-
-@defform*[[(->pp-rest ([id expr] ...) id expr pre-expr
-                      res-expr res-id post-expr)
-           (->pp-rest ([id expr] ...) id expr pre-expr any)
-           (->pp-rest ([id expr] ...) id expr pre-expr 
-                      (values [id expr] ...) post-expr)]]{
-
-Like @scheme[->pp], but for the ``rest''-argument cases of
-@scheme[->r].}
-
-
-@defform[(case-> arrow-contract-expr ...)]{
-
-Constructs a contract for a @scheme[case-lambda] procedure. Its
-arguments must all be function contracts, built by one of @scheme[->],
-@scheme[->d], @scheme[->*], @scheme[->d*], @scheme[->r],
-@scheme[->pp], or @scheme[->pp-rest].}
-
-
-@defform*[#:literals (any)
-          [(opt-> (req-expr ...) (opt-expr ...) res-expr)
-           (opt-> (req-expr ...) (opt-expr ...) any)]]{
-
-Like @scheme[->], but for a function with a fixed number of optional
-by-position arguments. Each @scheme[req-expr] corresponds to a
-required argument, and each @scheme[opt-expr] corresponds to an
-optional argument.}
-
-
-@defform*[#:literals (any)
-          [(opt->* (req-expr ...) (opt-expr ...) (res-expr ...))
-           (opt->* (req-expr ...) (opt-expr ...) any)]]{
-
-Like @scheme[opt->], but with support for multiple results as in
-@scheme[->*].}
-
+@defform*/subs[#:literals (any values)
+[(case-> (-> dom-expr ... rest range) ...)]
+([rest (code:line) (code:line #:rest rest-expr)]
+ [range range-expr (values range-expr ...) any])]
+{
+case->.
 }
+}
+
 @defform[(unconstrained-domain-> res-expr ...)]{
 
 Constructs a contract that accepts a function, but makes no constraint
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 86087d87f0..ee283af4c4 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -168,29 +168,19 @@
   (test/no-error '(-> integer? any))
   (test/no-error '(-> (flat-contract integer?) any))
   
-  (test/no-error '(->* (integer?) () (integer?)))
-  (test/no-error '(->* (integer?) () integer? (integer?)))
+  (test/no-error '(->* (integer?) () (values integer?)))
+  (test/no-error '(->* (integer?) () integer? integer?))
   (test/no-error '(->* (integer?) () integer? any))
-  (test/no-error '(->* ((flat-contract integer?)) () ((flat-contract integer?))))
-  (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) ((flat-contract integer?))))
+  (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?)))
+  (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) (flat-contract integer?)))
+  (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) 
+                       (values (flat-contract integer?) (flat-contract boolean?))))
   (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) any))
   
-  (test/no-error '(->d integer? (lambda (x) integer?)))
-  (test/no-error '(->d (flat-contract integer?) (lambda (x) (flat-contract integer?))))
+  (test/no-error '(->d ([x integer?]) ([y integer?]) any))
+  (test/no-error '(->d ([x integer?]) ([y integer?]) (number? boolean?)))
+  (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) (number? boolean?)))
 
-  (test/no-error '(->d* (integer?) (lambda (x) integer?)))
-  (test/no-error '(->d* ((flat-contract integer?)) (lambda (x) (flat-contract integer?))))
-  (test/no-error '(->d* (integer?) integer? (lambda (x . y) integer?)))
-  (test/no-error '(->d* ((flat-contract integer?)) (flat-contract integer?) (lambda (x . y) (flat-contract integer?))))
-  
-  (test/no-error '(opt-> (integer?) (integer?) integer?))
-  (test/no-error '(opt-> ((flat-contract integer?)) ((flat-contract integer?)) (flat-contract integer?)))
-  (test/no-error '(opt-> ((flat-contract integer?)) ((flat-contract integer?)) any))
-  (test/no-error '(opt->* (integer?) (integer?) (integer?)))
-  (test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) ((flat-contract integer?))))
-  (test/no-error '(opt->* (integer?) (integer?) any))
-  (test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) any))
-  
   (test/no-error '(unconstrained-domain-> number?))
   (test/no-error '(unconstrained-domain-> (flat-contract number?)))
   
@@ -239,14 +229,14 @@
   
   (test/spec-passed
    'contract-arrow-star0a
-   '(contract (->* (integer?) () (integer?))
+   '(contract (->* (integer?) () integer?)
               (lambda (x) x)
               'pos
               'neg))
   
   (test/neg-blame
    'contract-arrow-star0b
-   '((contract (->* (integer?) () (integer?))
+   '((contract (->* (integer?) () integer?)
                (lambda (x) x)
                'pos
                'neg)
@@ -254,7 +244,7 @@
   
   (test/pos-blame
    'contract-arrow-star0c
-   '((contract (->* (integer?) () (integer?))
+   '((contract (->* (integer?) () integer?)
                (lambda (x) #f)
                'pos
                'neg)
@@ -262,7 +252,7 @@
   
   (test/spec-passed
    'contract-arrow-star1
-   '(let-values ([(a b) ((contract (->* (integer?) () (integer? integer?))
+   '(let-values ([(a b) ((contract (->* (integer?) () (values integer? integer?))
                                    (lambda (x) (values x x))
                                    'pos
                                    'neg)
@@ -271,7 +261,7 @@
   
   (test/neg-blame
    'contract-arrow-star2
-   '((contract (->* (integer?) () (integer? integer?))
+   '((contract (->* (integer?) () (values integer? integer?))
                (lambda (x) (values x x))
                'pos
                'neg)
@@ -279,7 +269,7 @@
   
   (test/pos-blame
    'contract-arrow-star3
-   '((contract (->* (integer?) () (integer? integer?))
+   '((contract (->* (integer?) () (values integer? integer?))
                (lambda (x) (values 1 #t))
                'pos
                'neg)
@@ -287,7 +277,7 @@
   
   (test/pos-blame
    'contract-arrow-star4
-   '((contract (->* (integer?) () (integer? integer?))
+   '((contract (->* (integer?) () (values integer? integer?))
                (lambda (x) (values #t 1))
                'pos
                'neg)
@@ -298,7 +288,7 @@
    'contract-arrow-star5
    '(let-values ([(a b) ((contract (->* (integer?) () 
                                         (listof integer?)
-                                        (integer? integer?))
+                                        (values integer? integer?))
                                    (lambda (x . y) (values x x))
                                    'pos
                                    'neg)
@@ -307,7 +297,7 @@
   
   (test/neg-blame
    'contract-arrow-star6
-   '((contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer?) () (listof integer?) (values integer? integer?))
                (lambda (x . y) (values x x))
                'pos
                'neg)
@@ -315,7 +305,7 @@
   
   (test/pos-blame
    'contract-arrow-star7
-   '((contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer?) () (listof integer?) (values integer? integer?))
                (lambda (x . y) (values 1 #t))
                'pos
                'neg)
@@ -323,7 +313,7 @@
   
   (test/pos-blame
    'contract-arrow-star8
-   '((contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer?) () (listof integer?) (values integer? integer?))
                (lambda (x) (values #t 1))
                'pos
                'neg)
@@ -331,7 +321,7 @@
   
   (test/spec-passed
    'contract-arrow-star9
-   '((contract (->* (integer?) () (listof integer?) (integer?))
+   '((contract (->* (integer?) () (listof integer?) integer?)
                (lambda (x . y) 1)
                'pos
                'neg)
@@ -339,7 +329,7 @@
   
   (test/neg-blame
    'contract-arrow-star10
-   '((contract (->* (integer?) () (listof integer?) (integer?))
+   '((contract (->* (integer?) () (listof integer?) integer?)
                (lambda (x . y) 1)
                'pos
                'neg)
@@ -418,35 +408,35 @@
 
   (test/pos-blame
    'contract-arrow-star-arity-check1
-   '(contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '(contract (->* (integer?) () (listof integer?) (values integer? integer?))
               (lambda (x) (values 1 #t))
               'pos
               'neg))
   
   (test/pos-blame
    'contract-arrow-star-arity-check2
-   '(contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '(contract (->* (integer?) () (listof integer?) (values integer? integer?))
               (lambda (x y) (values 1 #t))
               'pos
               'neg))
   
   (test/pos-blame
    'contract-arrow-star-arity-check3
-   '(contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '(contract (->* (integer?) () (listof integer?) (values integer? integer?))
               (case-lambda [(x y) #f] [(x y . z) #t])
               'pos
               'neg))
   
   (test/spec-passed
    'contract-arrow-star-arity-check4
-   '(contract (->* (integer?) () (listof integer?) (integer? integer?))
+   '(contract (->* (integer?) () (listof integer?) (values integer? integer?))
               (case-lambda [(x y) #f] [(x y . z) #t] [(x) #f])
               'pos
               'neg))
   
   (test/pos-blame
    'contract-arrow-star-keyword1
-   '(contract (->* (integer?) () (listof integer?) (integer?))
+   '(contract (->* (integer?) () (listof integer?) (values integer?))
               (λ (x #:y y . args) x)
               'pos
               'neg))
@@ -460,7 +450,7 @@
   
   (test/spec-passed
    'contract-arrow-star-keyword3
-   '(contract (->* (integer? #:y integer?) () (listof integer?) (integer? integer?))
+   '(contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?))
               (λ (x #:y y . args) x)
               'pos
               'neg))
@@ -474,7 +464,7 @@
   
   (test/neg-blame
    'contract-arrow-star-keyword5
-   '((contract (->* (integer? #:y integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?))
                (λ (x #:y y . args) x)
                'pos
                'neg)
@@ -490,7 +480,7 @@
   
   (test/neg-blame
    'contract-arrow-star-keyword7
-   '((contract (->* (integer? #:y integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?))
                (λ (x #:y y . args) x)
                'pos
                'neg)
@@ -506,7 +496,7 @@
   
   (test/spec-passed
    'contract-arrow-star-keyword9
-   '((contract (->* (integer? #:y integer?) () (listof integer?) (integer? integer?))
+   '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?))
                (λ (x #:y y . args) (values x x))
                'pos
                'neg)
@@ -599,35 +589,35 @@
 
   (test/spec-passed
    'contract-arrow-star-optional11
-   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
               (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                 (list x s c i))
               'pos 'neg))
   
   (test/pos-blame
    'contract-arrow-star-optional12
-   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
               (λ (#:x x #:z [c #\c] [i 5])
                 (list x s c i))
               'pos 'neg))
   
   (test/spec-passed
    'contract-arrow-star-optional13
-   '(contract (->* (#:x boolean?) (#:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '(contract (->* (#:x boolean?) (#:z char? integer?) (list/c boolean? string? char? integer?))
               (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                 (list x s c i))
               'pos 'neg))
   
   (test/pos-blame
    'contract-arrow-star-optional14
-   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '(contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
               (λ (#:x x #:y [s "s"] #:z [c #\c])
                 (list x s c i))
               'pos 'neg))
   
   (test/spec-passed/result
    'contract-arrow-star-optional15
-   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
                (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                  (list x s c i))
                'pos 'neg)
@@ -636,7 +626,7 @@
   
   (test/spec-passed/result
    'contract-arrow-star-optional16
-   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
                (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                  (list x s c i))
                'pos 'neg)
@@ -645,7 +635,7 @@
   
   (test/neg-blame
    'contract-arrow-star-optional17
-   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
                (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                  (list x s c i))
                'pos 'neg)
@@ -653,7 +643,7 @@
   
   (test/neg-blame
    'contract-arrow-star-optional18
-   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
                (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                  (list x s c i))
                'pos 'neg)
@@ -661,7 +651,7 @@
   
   (test/neg-blame
    'contract-arrow-star-optional19
-   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) ((list/c boolean? string? char? integer?)))
+   '((contract (->* (#:x boolean?) (#:y string? #:z char? integer?) (list/c boolean? string? char? integer?))
                (λ (#:x x #:y [s "s"] #:z [c #\c] [i 5])
                  (list x s c i))
                'pos 'neg)
@@ -669,26 +659,26 @@
   
   (test/pos-blame
    'contract-arrow-star-optional20
-   '(contract (->* (#:x boolean?) (#:y string?) ((list/c boolean? string? char? integer?)))
+   '(contract (->* (#:x boolean?) (#:y string?) (list/c boolean? string? char? integer?))
               (λ (#:x [x #f] #:y s)
                 (list x s c i))
               'pos 'neg))
   
   (test/spec-passed
    'contract-arrow-star-optional21
-   '((contract (->* () () ())
+   '((contract (->* () () (values))
                (λ () (values))
                'pos 'neg)))
   
   (test/spec-passed
    'contract-arrow-star-optional22
-   '((contract (->* () () (integer? char?))
+   '((contract (->* () () (values integer? char?))
                (λ () (values 1 #\c))
                'pos 'neg)))
   
   (test/pos-blame
    'contract-arrow-star-optional23
-   '((contract (->* () () (integer? char?))
+   '((contract (->* () () (values integer? char?))
                (λ () (values 1 2))
                'pos 'neg)))
   
@@ -901,44 +891,6 @@
                'neg)
      1 #:y #t))
 
-  (test/pos-blame
-   'contract-d1
-   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-              1
-              'pos
-              'neg))
-  
-  (test/spec-passed
-   'contract-d2
-   '(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-              (lambda (x) x)
-              'pos
-              'neg))
-  
-  (test/pos-blame
-   'contract-d2
-   '((contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
-               (lambda (x) (+ x 1))
-               'pos
-               'neg)
-     2))
-
-  (test/neg-blame
-   'contract-d3
-   '((contract (integer? . ->d . (lambda (x)  (let ([z (+ x 1)]) (lambda (y) (= z y)))))
-               (lambda (x) (+ x 1))
-               'pos
-               'neg)
-     "bad input"))
-  
-  (test/neg-blame
-   'contract-d4
-   '((contract (integer? . ->d . (lambda (x)  (lambda (y) (= (+ x 1) y))))
-               (lambda (x) (+ x 1))
-               'pos
-               'neg)
-     "bad input"))
-  
   (test/spec-passed
    'contract-arrow1
    '(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
@@ -976,378 +928,217 @@
 
   
 
-;                                  
-;                                  
-;                                  
-;                    ;;;;    ;;;   
-;        ;           ;;;;  ; ;;; ; 
-;        ;;;      ;;;;;;; ;;;;;;;;;
-;         ;;;;   ;;;;;;;;  ;;;;;;; 
-;           ;;; ;;;;;;;;;  ;;;;;;; 
-;  ;;;;;    ;;; ;;;; ;;;; ;;;;;;;;;
-;  ;;;;;  ;;;;  ;;;;;;;;;  ; ;;; ; 
-;        ;;;     ;;;;;;;;    ;;;   
-;        ;        ;;;;;;;          
-;                                  
-;                                  
-;                                  
-
-  
-  (test/spec-passed
-   'contract-arrow-star-d1
-   '((contract (->d* (integer?) (lambda (arg) (lambda (res) (= arg res))))
-               (lambda (x) x)
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-passed
-   'contract-arrow-star-d2
-   '(let-values ([(a b)
-                  ((contract (->d* (integer?) (lambda (arg) 
-                                                (values (lambda (res) (= arg res)) 
-                                                        (lambda (res) (= arg res)))))
-                             (lambda (x) (values x x))
-                             'pos
-                             'neg)
-                   1)])
-      1))
-  
-  (test/pos-blame
-   'contract-arrow-star-d3
-   '((contract (->d* (integer?) (lambda (arg) 
-                                  (values (lambda (res) (= arg res)) 
-                                          (lambda (res) (= arg res)))))
-               (lambda (x) (values 1 2))
-               'pos
-               'neg)
-     2))
-  
-  (test/pos-blame
-   'contract-arrow-star-d4
-   '((contract (->d* (integer?) (lambda (arg) 
-                                  (values (lambda (res) (= arg res)) 
-                                          (lambda (res) (= arg res)))))
-               (lambda (x) (values 2 1))
-               'pos
-               'neg)
-     2))
-  
-  (test/spec-passed
-   'contract-arrow-star-d5
-   '((contract (->d* ()
-                     (listof integer?)
-                     (lambda args (lambda (res) (= (car args) res))))
-               (lambda x (car x))
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-passed
-   'contract-arrow-star-d6
-   '((contract (->d* () 
-                     (listof integer?)
-                     (lambda args
-                       (values (lambda (res) (= (car args) res)) 
-                               (lambda (res) (= (car args) res)))))
-               (lambda x (values (car x) (car x)))
-               'pos
-               'neg)
-     1))
-  
-  (test/pos-blame
-   'contract-arrow-star-d7
-   '((contract (->d* () 
-                     (listof integer?)
-                     (lambda args
-                       (values (lambda (res) (= (car args) res)) 
-                               (lambda (res) (= (car args) res)))))
-               (lambda x (values 1 2))
-               'pos
-               'neg)
-     2))
-  
-  (test/pos-blame
-   'contract-arrow-star-d8
-   '((contract (->d* ()
-                     (listof integer?)
-                     (lambda args
-                       (values (lambda (res) (= (car args) res)) 
-                               (lambda (res) (= (car args) res)))))
-               (lambda x (values 2 1))
-               'pos
-               'neg)
-     2))
-  
-  (test/pos-blame
-   'contract-arrow-star-d8
-   '(contract (->d* ()
-                    (listof integer?)
-                    (lambda arg
-                      (values (lambda (res) (= (car arg) res)) 
-                              (lambda (res) (= (car arg) res)))))
-              (lambda (x) (values 2 1))
-              'pos
-              'neg))
-
-  
-;                                          
-;                                          
-;                                          
-;                          ;;;;  ;;        
-;                          ;;;;  ;;        
-;  ;;;;;;;  ;;;; ;;;    ;;;;;;;  ;;  ;;;;; 
-;  ;;;;;;;; ;;;;;;;;;  ;;;;;;;;  ;; ;;;;;; 
-;      ;;;; ;;;; ;;;; ;;;;;;;;;  ;;;;;;;;; 
-;   ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;; ;;;;    
-;  ;;  ;;;; ;;;; ;;;; ;;;;;;;;; ;; ;;;;;;; 
-;  ;;;;;;;; ;;;; ;;;;  ;;;;;;;; ;;  ;;;;;; 
-;   ;; ;;;; ;;;; ;;;;   ;;;;;;; ;;   ;;;;; 
-;                               ;;         
-;                                          
-;                                          
-
-  
-  (test/spec-passed
-   'and/c1
-   '((contract (and/c (-> (<=/c 100) (<=/c 100))
-                      (-> (>=/c -100) (>=/c -100)))
-               (λ (x) x)
-               'pos
-               'neg)
-     1))
-  
-  (test/neg-blame
-   'and/c2
-   '((contract (and/c (-> (<=/c 100) (<=/c 100))
-                      (-> (>=/c -100) (>=/c -100)))
-               (λ (x) x)
-               'pos
-               'neg)
-     200))
-  
-  (test/pos-blame
-   'and/c3
-   '((contract (and/c (-> (<=/c 100) (<=/c 100))
-                      (-> (>=/c -100) (>=/c -100)))
-               (λ (x) 200)
-               'pos
-               'neg)
-     1))
-  
-
-  
-;                       
-;                       
-;                       
-;                       
-;        ;              
-;        ;;;    ;;; ;;; 
-;         ;;;;  ;;;;;;; 
-;           ;;; ;;;; ;; 
-;  ;;;;;    ;;; ;;;;    
-;  ;;;;;  ;;;;  ;;;;    
-;        ;;;    ;;;;    
-;        ;      ;;;;    
-;                       
-;                       
-;                       
+;                         
+;                         
+;                         
+;                    ;;;; 
+;        ;           ;;;; 
+;        ;;;      ;;;;;;; 
+;         ;;;;   ;;;;;;;; 
+;           ;;; ;;;;;;;;; 
+;  ;;;;;    ;;; ;;;; ;;;; 
+;  ;;;;;  ;;;;  ;;;;;;;;; 
+;        ;;;     ;;;;;;;; 
+;        ;        ;;;;;;; 
+;                         
+;                         
+;                         
 
   (test/spec-passed
-   '->r1
-   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
+   '->d1
+   '((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg)))
   
   (test/spec-passed
-   '->r2
-   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+   '->d2
+   '((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1))
 
   (test/pos-blame
-   '->r3
-   '((contract (->r () number?) 1 'pos 'neg)))
+   '->d3
+   '((contract (->d () () [r number?]) 1 'pos 'neg)))
   
   (test/pos-blame
-   '->r4
-   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
+   '->d4
+   '((contract (->d () () [r number?]) (lambda (x) x) 'pos 'neg)))
   
   (test/neg-blame
-   '->r5
-   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+   '->d5
+   '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
   
   (test/pos-blame
-   '->r6
-   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+   '->d6
+   '((contract (->d ([x number?]) () [r (<=/c x)]) (lambda (x) (+ x 1)) 'pos 'neg) 1))
   
   (test/spec-passed
-   '->r7
-   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+   '->d7
+   '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
   
   (test/neg-blame
-   '->r8
-   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+   '->d8
+   '((contract (->d ([x number?] [y (<=/c x)]) () [r (<=/c x)]) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
   
   (test/spec-passed
-   '->r9
-   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+   '->d9
+   '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
   
   (test/neg-blame
-   '->r10
-   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
-  
-  (test/spec-passed
-   '->r11
-   '((contract (->r () rest any/c number?) (lambda x 1) 'pos 'neg)))
-  
-  (test/spec-passed
-   '->r12
-   '((contract (->r ([x number?]) rest any/c number?) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
-
-  (test/pos-blame
-   '->r13
-   '((contract (->r () rest any/c number?) 1 'pos 'neg)))
-  
-  (test/pos-blame
-   '->r14
-   '((contract (->r () rest any/c number?) (lambda (x) x) 'pos 'neg)))
-  
-  (test/neg-blame
-   '->r15
-   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
-  
-  (test/pos-blame
-   '->r16
-   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
-  
-  (test/spec-passed
-   '->r17
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
-  
-  (test/neg-blame
-   '->r18
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
-  
-  (test/spec-passed
-   '->r19
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
-  
-  (test/neg-blame
-   '->r20
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+   '->d10
+   '((contract (->d ([y (<=/c x)] [x number?]) () [r (<=/c x)]) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
 
   (test/spec-passed
-   '->r21
-   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) 1))
-  
-  (test/neg-blame
-   '->r22
-   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) #f))
+   '->d11
+   '((contract (->d () () rest any/c [r number?]) (lambda x 1) 'pos 'neg)))
   
   (test/spec-passed
-   '->r-any1
-   '((contract (->r () any) (lambda () 1) 'pos 'neg)))
-  
-  (test/spec-passed
-   '->r-any2
-   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+   '->d12
+   '((contract (->d ([x number?]) () rest any/c [r number?]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
 
   (test/pos-blame
-   '->r-any3
-   '((contract (->r () any) 1 'pos 'neg)))
+   '->d13
+   '((contract (->d () () rest any/c [r number?]) 1 'pos 'neg)))
   
   (test/pos-blame
-   '->r-any4
-   '((contract (->r () any) (lambda (x) x) 'pos 'neg)))
+   '->d14
+   '((contract (->d () () rest any/c [r number?]) (lambda (x) x) 'pos 'neg)))
   
   (test/neg-blame
-   '->r-any5
-   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
-  
-  (test/spec-passed
-   '->r-any6
-   '((contract (->r ([x number?] [y (<=/c x)]) any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
-  
-  (test/neg-blame
-   '->r-any7
-   '((contract (->r ([x number?] [y (<=/c x)]) any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
-  
-  (test/spec-passed
-   '->r-any8
-   '((contract (->r ([y (<=/c x)] [x number?]) any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
-  
-  (test/neg-blame
-   '->r-any9
-   '((contract (->r ([y (<=/c x)] [x number?]) any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
-  
-  (test/spec-passed
-   '->r-any10
-   '((contract (->r () rest any/c any) (lambda x 1) 'pos 'neg)))
-  
-  (test/spec-passed
-   '->r-any11
-   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
-
-  (test/pos-blame
-   '->r-any12
-   '((contract (->r () rest any/c any) 1 'pos 'neg)))
+   '->d15
+   '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
   
   (test/pos-blame
-   '->r-any13
-   '((contract (->r () rest any/c any) (lambda (x) x) 'pos 'neg)))
-  
-  (test/neg-blame
-   '->r-any14
-   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
+   '->d16
+   '((contract (->d ([x number?]) () rest any/c [r (<=/c x)]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
   
   (test/spec-passed
-   '->r-any15
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c any) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
+   '->d17
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c [r (<=/c x)]) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
   
   (test/neg-blame
-   '->r-any16
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c any) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
+   '->d18
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c [r (<=/c x)]) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
   
   (test/spec-passed
-   '->r-any17
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c any) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
+   '->d19
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c [r (<=/c x)]) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
   
   (test/neg-blame
-   '->r-any18
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c any) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+   '->d20
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c [r (<=/c x)]) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
 
   (test/spec-passed
-   '->r-any19
-   '((contract (->r () rst (listof number?) any) (lambda w 1) 'pos 'neg) 1))
+   '->d21
+   '((contract (->d () () rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) 1))
   
   (test/neg-blame
-   '->r-any20
-   '((contract (->r () rst (listof number?) any) (lambda w 1) 'pos 'neg) #f))
+   '->d22
+   '((contract (->d () () rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) #f))
   
   (test/spec-passed
-   '->r-values1
-   '((contract (->r () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg)))
+   '->d-any1
+   '((contract (->d () () any) (lambda () 1) 'pos 'neg)))
   
   (test/spec-passed
-   '->r-values2
-   '((contract (->r ([x number?]) (values [x boolean?] [y number?])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+   '->d-any2
+   '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) 1))
 
   (test/pos-blame
-   '->r-values3
-   '((contract (->r () (values [x boolean?] [y number?])) 1 'pos 'neg)))
+   '->d-any3
+   '((contract (->d () () any) 1 'pos 'neg)))
   
   (test/pos-blame
-   '->r-values4
-   '((contract (->r () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg)))
+   '->d-any4
+   '((contract (->d () () any) (lambda (x) x) 'pos 'neg)))
   
   (test/neg-blame
-   '->r-values5
-   '((contract (->r ([x number?]) (values [y boolean?] [z (<=/c x)])) (lambda (x) (+ x 1)) 'pos 'neg) #f))
-  
-  (test/pos-blame
-   '->r-values6
-   '((contract (->r ([x number?]) (values [y boolean?] [z (<=/c x)])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+   '->d-any5
+   '((contract (->d ([x number?]) () any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
   
   (test/spec-passed
-   '->r-values7
-   '((contract (->r ([x number?] [y (<=/c x)]) (values [z boolean?] [w (<=/c x)])) 
+   '->d-any6
+   '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->d-any7
+   '((contract (->d ([x number?] [y (<=/c x)]) () any) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->d-any8
+   '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->d-any9
+   '((contract (->d ([y (<=/c x)] [x number?]) () any) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
+  (test/spec-passed
+   '->d-any10
+   '((contract (->d () () rest any/c any) (lambda x 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->d-any11
+   '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->d-any12
+   '((contract (->d () () rest any/c any) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->d-any13
+   '((contract (->d () () rest any/c any) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->d-any14
+   '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/spec-passed
+   '->d-any15
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c any) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->d-any16
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c any) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->d-any17
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c any) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->d-any18
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c any) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
+
+  (test/spec-passed
+   '->d-any19
+   '((contract (->d () () rst (listof number?) any) (lambda w 1) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   '->d-any20
+   '((contract (->d () () rst (listof number?) any) (lambda w 1) 'pos 'neg) #f))
+
+  (test/spec-passed
+   '->d-values1
+   '((contract (->d () () (values [x boolean?] [y number?])) (lambda () (values #t 1)) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->d-values2
+   '((contract (->d ([x number?]) () (values [z boolean?] [y number?])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->d-values3
+   '((contract (->d () () (values [x boolean?] [y number?])) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->d-values4
+   '((contract (->d () () (values [x boolean?] [y number?])) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->d-values5
+   '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->d-values6
+   '((contract (->d ([x number?]) () (values [y boolean?] [z (<=/c x)])) (lambda (x) (values #t (+ x 1))) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->d-values7
+   '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) 
                (lambda (x y) (values #t (- x 1)))
                'pos
                'neg) 
@@ -1355,8 +1146,8 @@
      0))
   
   (test/neg-blame
-   '->r-values8
-   '((contract (->r ([x number?] [y (<=/c x)]) (values [z boolean?] [w (<=/c x)])) 
+   '->d-values8
+   '((contract (->d ([x number?] [y (<=/c x)]) () (values [z boolean?] [w (<=/c x)])) 
                (lambda (x y) (values #f (+ x 1)))
                'pos
                'neg)
@@ -1364,8 +1155,8 @@
      2))
   
   (test/spec-passed
-   '->r-values9
-   '((contract (->r ([y (<=/c x)] [x number?]) (values [z boolean?] [w (<=/c x)]))
+   '->d-values9
+   '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)]))
                (lambda (y x) (values #f (- x 1)))
                'pos 
                'neg)
@@ -1373,185 +1164,94 @@
      2))
   
   (test/neg-blame
-   '->r-values10
-   '((contract (->r ([y (<=/c x)] [x number?]) (values [z boolean?] [w (<=/c x)]))
+   '->d-values10
+   '((contract (->d ([y (<=/c x)] [x number?]) () (values [z boolean?] [w (<=/c x)]))
                (lambda (y x) (values #f (+ x 1))) 'pos 'neg)
      1 0))
   
   (test/spec-passed
-   '->r-values11
-   '((contract (->r () rest any/c (values [z boolean?] [w number?])) (lambda x (values #f 1)) 'pos 'neg)))
+   '->d-values11
+   '((contract (->d () () rest any/c (values [z boolean?] [w number?])) (lambda x (values #f 1)) 'pos 'neg)))
   
   (test/spec-passed
-   '->r-values12
-   '((contract (->r ([x number?]) rest any/c (values [z boolean?] [w number?]))
+   '->d-values12
+   '((contract (->d ([x number?]) () rest any/c (values [z boolean?] [w number?]))
                (lambda (x . y) (values #f (+ x 1)))
                'pos 
                'neg)
      1))
 
   (test/pos-blame
-   '->r-values13
-   '((contract (->r () rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg)))
+   '->d-values13
+   '((contract (->d () () rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg)))
   
   (test/pos-blame
-   '->r-values14
-   '((contract (->r () rest any/c (values [z boolean?] [w number?])) (lambda (x) x) 'pos 'neg)))
+   '->d-values14
+   '((contract (->d () () rest any/c (values [z boolean?] [w number?])) (lambda (x) x) 'pos 'neg)))
   
   (test/neg-blame
-   '->r-values15
-   '((contract (->r ([x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+   '->d-values15
+   '((contract (->d ([x number?]) () rest any/c  (values [z boolean?] [w (<=/c x)]))
                (lambda (x . y) (+ x 1)) 'pos 'neg)
      #f))
   
   (test/pos-blame
-   '->r-values16
-   '((contract (->r ([x number?]) rest any/c (values [z boolean?] [w (<=/c x)]))
+   '->d-values16
+   '((contract (->d ([x number?]) () rest any/c (values [z boolean?] [w (<=/c x)]))
                (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) 
      1))
   
   (test/spec-passed
-   '->r-values17
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (values [z boolean?] [w (<=/c x)]))
+   '->d-values17
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c (values [z boolean?] [w (<=/c x)]))
                (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) 
      1 0))
   
   (test/neg-blame
-   '->r-values18
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (values [z boolean?] [w (<=/c x)]))
+   '->d-values18
+   '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c (values [z boolean?] [w (<=/c x)]))
                (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) 
      1 2))
   
   (test/spec-passed
-   '->r-values19
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+   '->d-values19
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c  (values [z boolean?] [w (<=/c x)]))
                (lambda (y x . z) (values #f (- x 1))) 'pos 'neg)
      1 2))
   
   (test/neg-blame
-   '->r-values20
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c  (values [z boolean?] [w (<=/c x)]))
+   '->d-values20
+   '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c  (values [z boolean?] [w (<=/c x)]))
                (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) 
      1 0))
 
   (test/spec-passed
-   '->r-values21
-   '((contract (->r () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) 1))
+   '->d-values21
+   '((contract (->d () () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) 1))
   
   (test/neg-blame
-   '->r-values22
-   '((contract (->r () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) #f))
+   '->d-values22
+   '((contract (->d () () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) #f))
 
   (test/spec-passed
-   '->r-values23
-   '((contract (->r () (values [x number?] [y (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg)))
+   '->d-values23
+   '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 1 2)) 'pos 'neg)))
   
   (test/pos-blame
-   '->r-values24
-   '((contract (->r () (values [x number?] [y (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg)))
+   '->d-values24
+   '((contract (->d () () (values [x number?] [y (>=/c x)])) (lambda () (values 2 1)) 'pos 'neg)))
 
   (test/spec-passed
-   '->r-values25
-   '((contract (->r ([x number?]) (values [z number?] [y (>=/c x)])) (lambda (x) (values 1 2)) 'pos 'neg) 1))
+   '->d-values25
+   '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) (lambda (x) (values 1 2)) 'pos 'neg) 1))
   
   (test/pos-blame
-   '->r-values26
-   '((contract (->r ([x number?]) (values [z number?] [y (>=/c x)])) (lambda (x) (values 2 1)) 'pos 'neg) 4))
+   '->d-values26
+   '((contract (->d ([x number?]) () (values [z number?] [y (>=/c x)])) (lambda (x) (values 2 1)) 'pos 'neg) 4))
 
-
-    
-  (test/spec-passed
-   '->r1
-   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
-  
-  (test/spec-passed
-   '->r2
-   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
-
-  (test/pos-blame
-   '->r3
-   '((contract (->r () number?) 1 'pos 'neg)))
-  
-  (test/pos-blame
-   '->r4
-   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
-  
-  (test/neg-blame
-   '->r5
-   '((contract (->r ([x number?]) any) (lambda (x) (+ x 1)) 'pos 'neg) #f))
-  
-  (test/pos-blame
-   '->r6
-   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
-  
-  (test/spec-passed
-   '->r7
-   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
-  
-  (test/neg-blame
-   '->r8
-   '((contract (->r ([x number?] [y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
-  
-  (test/spec-passed
-   '->r9
-   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
-  
-  (test/neg-blame
-   '->r10
-   '((contract (->r ([y (<=/c x)] [x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
-  
-  (test/spec-passed
-   '->r11
-   '((contract (->r () rest any/c number?) (lambda x 1) 'pos 'neg)))
-  
-  (test/spec-passed
-   '->r12
-   '((contract (->r ([x number?]) rest any/c number?) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
-
-  (test/pos-blame
-   '->r13
-   '((contract (->r () rest any/c number?) 1 'pos 'neg)))
-  
-  (test/pos-blame
-   '->r14
-   '((contract (->r () rest any/c number?) (lambda (x) x) 'pos 'neg)))
-  
-  (test/neg-blame
-   '->r15
-   '((contract (->r ([x number?]) rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f))
-  
-  (test/pos-blame
-   '->r16
-   '((contract (->r ([x number?]) rest any/c (<=/c x)) (lambda (x . y) (+ x 1)) 'pos 'neg) 1))
-  
-  (test/spec-passed
-   '->r17
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0))
-  
-  (test/neg-blame
-   '->r18
-   '((contract (->r ([x number?] [y (<=/c x)]) rest any/c (<=/c x)) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2))
-  
-  (test/spec-passed
-   '->r19
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2))
-  
-  (test/neg-blame
-   '->r20
-   '((contract (->r ([y (<=/c x)] [x number?]) rest any/c (<=/c x)) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0))
-
-  (test/spec-passed
-   '->r21
-   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) 1))
-  
-  (test/neg-blame
-   '->r22
-   '((contract (->r () rst (listof number?) any/c) (lambda w 1) 'pos 'neg) #f))
-
-  
   (test/spec-passed/result
-   '->r23
-   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) number?)
+   '->d23
+   '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () [r number?])
                (λ (i j) 1)
                'pos
                'neg)
@@ -1560,8 +1260,8 @@
    1)
 
   (test/spec-passed/result
-   '->r24
-   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) any)
+   '->d24
+   '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () any)
                (λ (i j) 1)
                'pos
                'neg)
@@ -1570,10 +1270,10 @@
    1)
 
   (test/spec-passed/result
-   '->r25
+   '->d25
    '(call-with-values
     (λ ()
-      ((contract (->r ((i number?) (j (and/c number? (>=/c i)))) (values [x number?] [y number?]))
+      ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () (values [x number?] [y number?]))
                  (λ (i j) (values 1 2))
                  'pos
                  'neg)
@@ -1583,8 +1283,8 @@
    '(1 2))
 
   (test/spec-passed/result
-   '->r26
-   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c number?)
+   '->d26
+   '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c [r number?])
                (λ (i j . z) 1)
                'pos
                'neg)
@@ -1593,8 +1293,8 @@
    1)
 
   (test/spec-passed/result
-   '->r27
-   '((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c any)
+   '->d27
+   '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c any)
                (λ (i j . z) 1)
                'pos
                'neg)
@@ -1603,10 +1303,10 @@
    1)
 
 (test/spec-passed/result
- '->r28
+ '->d28
  '(call-with-values
    (λ ()
-     ((contract (->r ((i number?) (j (and/c number? (>=/c i)))) rest-args any/c (values [x number?] [y number?]))
+     ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c (values [x number?] [y number?]))
                 (λ (i j . z) (values 1 2))
                 'pos
                 'neg)
@@ -1614,138 +1314,226 @@
       2))
    list)
  '(1 2))
-
-
-  
-;                                   
-;                                   
-;                                   
-;                                   
-;        ;                          
-;        ;;;    ;;;;;;;   ;;;;;;;   
-;         ;;;;  ;;;;;;;;  ;;;;;;;;  
-;           ;;; ;;;;;;;;; ;;;;;;;;; 
-;  ;;;;;    ;;; ;;;; ;;;; ;;;; ;;;; 
-;  ;;;;;  ;;;;  ;;;;;;;;; ;;;;;;;;; 
-;        ;;;    ;;;;;;;;  ;;;;;;;;  
-;        ;      ;;;;;;;   ;;;;;;;   
-;               ;;;;      ;;;;      
-;               ;;;;      ;;;;      
-;                                   
-
   
+  (test/neg-blame
+   '->d30
+   '((contract (->d ([x number?]) () rst number? any)
+               (λ (x . rst) (values 4 5))
+               'pos
+               'neg)))
+    
   (test/pos-blame
-   '->pp1
-   '((contract (->pp ([x number?]) (= x 1) number? result (= x 2))
+   '->d-pp1
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2))
                (λ (x) x)
                'pos
                'neg)
      1))
   
   (test/neg-blame
-   '->pp2
-   '((contract (->pp ([x number?]) (= x 1) number? result (= x 2))
+   '->d-pp2
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2))
                (λ (x) x)
                'pos
                'neg)
      2))
   
   (test/pos-blame
-   '->pp3
-   '((contract (->pp ([x number?]) (= x 1) number? result (= result 2))
+   '->d-pp3
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2))
                (λ (x) x)
                'pos
                'neg)
      1))
   
   (test/spec-passed
-   '->pp3.5
-   '((contract (->pp ([x number?]) (= x 1) number? result (= result 2))
+   '->d-pp3.5
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= result 2))
                (λ (x) 2)
                'pos
                'neg)
      1))
   
   (test/neg-blame
-   '->pp4
-   '((contract (->pp ([x number?]) (= x 1) any)
+   '->d-pp4
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) any)
                (λ (x) x)
                'pos
                'neg)
      2))
   
   (test/neg-blame
-   '->pp5
-   '((contract (->pp ([x number?]) (= x 1) (values [x number?] [y number?]) (= x y 3))
+   '->d-pp5
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= x y z 3))
                (λ (x) (values 4 5))
                'pos
                'neg)
      2))
   
   (test/pos-blame
-   '->pp6
-   '((contract (->pp ([x number?]) (= x 1) (values [x number?] [y number?]) (= x y 3))
+   '->d-pp6
+   '((contract (->d ([x number?]) () #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= z y 3))
                (λ (x) (values 4 5))
                'pos
                'neg)
      1))
 
   (test/pos-blame
-   '->pp-r1
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= x 2))
+   '->d-pp-r1
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= x 2))
                (λ (x . rst) x)
                'pos
                'neg)
      1))
   
   (test/neg-blame
-   '->pp-r2
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1)  number? result (= x 2))
+   '->d-pp-r2
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1)  [result number?] #:post-cond (= x 2))
                (λ (x . rst) x)
                'pos
                'neg)
      2))
   
   (test/pos-blame
-   '->pp-r3
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= result 2))
+   '->d-pp-r3
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2))
                (λ (x . rst) x)
                'pos
                'neg)
      1))
   
   (test/spec-passed
-   '->pp-r3.5
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) number? result (= result 2))
+   '->d-pp-r3.5
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2))
                (λ (x . rst) 2)
                'pos
                'neg)
      1))
   
   (test/neg-blame
-   '->pp-r4
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) any)
+   '->d-pp-r4
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) any)
                (λ (x . rst) x)
                'pos
                'neg)
      2))
   
   (test/neg-blame
-   '->pp-r5
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) (values [x number?] [y number?]) (= x y 3))
+   '->d-pp-r5
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= x y z 3))
                (λ (x . rst) (values 4 5))
                'pos
                'neg)
      2))
   
   (test/pos-blame
-   '->pp-r6
-   '((contract (->pp-rest ([x number?]) rst any/c (= x 1) (values [x number?] [y number?]) (= x y 3))
+   '->d-pp-r6
+   '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= z x y 3))
                (λ (x . rst) (values 4 5))
                'pos
                'neg)
      1))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  make sure the variables are all bound properly
+  ;;
   
+  (test/spec-passed
+   '->d-binding1
+   '((contract (->d ([x number?]) () rest any/c [range any/c] #:post-cond (equal? rest '(2 3 4)))
+               (λ (x . y) y)
+               'pos
+               'neg)
+     1 2 3 4))
+  
+  (test/spec-passed
+   '->d-binding2
+   '((contract (->d ([x number?]) () rest any/c [range any/c] #:post-cond (equal? x 1))
+               (λ (x . y) y)
+               'pos
+               'neg)
+     1 2 3 4))
+  
+  (test/spec-passed
+   '->d-binding3
+   '(let ([p 'p]
+          [q 'q]
+          [r 'r])
+      ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) 
+                      ([a number?] [b number?] #:c [c number?] #:d [d number?])
+                      rest any/c 
+                      #:pre-cond (equal? (list x y z w a b c d rest p q r)
+                                         (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r))
+                      (values [p number?] [q number?] [r number?]))
+                 (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest)
+                   (values 11 12 13))
+                 'pos
+                 'neg)
+       1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z)))
+  
+  (test/spec-passed
+   '->d-binding4
+   '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) 
+                    ([a number?] [b number?] #:c [c number?] #:d [d number?])
+                    rest any/c 
+                    (values [p number?] [q number?] [r number?])
+                    #:post-cond (equal? (list x y z w a b c d rest p q r)
+                                        (list 1 2 3 4 5 6 7 8 '(z) 11 12 13)))
+               (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest)
+                 (values 11 12 13))
+               'pos
+               'neg)
+     1 2 #:z 3 #:w 4 5 6 #:c 7 #:d 8 'z))
+  
+  (test/spec-passed
+   '->d-binding5
+   '(let ([p 'p]
+          [q 'q]
+          [r 'r])
+      ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) 
+                      ([a number?] [b number?] #:c [c number?] #:d [d number?])
+                      rest any/c 
+                      #:pre-cond (equal? (list x y z w a b c d rest p q r)
+                                         (list 1 2 3 4 
+                                               the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg
+                                               '() 'p 'q 'r))
+                      (values [p number?] [q number?] [r number?]))
+                 (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest)
+                   (values 11 12 13))
+                 'pos
+                 'neg)
+       1 2 #:z 3 #:w 4)))
+  
+  (test/spec-passed
+   '->d-binding6
+   '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) 
+                    ([a number?] [b number?] #:c [c number?] #:d [d number?])
+                    rest any/c 
+                    (values [p number?] [q number?] [r number?])
+                    #:post-cond (equal? (list x y z w a b c d rest p q r)
+                                        (list 1 2 3 4
+                                              the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg
+                                              '() 11 12 13)))
+               (λ (x y #:z z #:w w [a 101] [b 102] #:c [c 103] #:d [d 104] . rest)
+                 (values 11 12 13))
+               'pos
+               'neg)
+     1 2 #:z 3 #:w 4))
+  
+  ;; test that the rest parameter is right when there aren't enough arguments to even make it to the rest parameter
+  (test/spec-passed
+   '->d-binding7
+   '((contract (->d () 
+                    ([a number?])
+                    rest any/c 
+                    any
+                    #:post-cond (equal? (list a rest) (list the-unsupplied-arg '())))
+               (λ ([a 1] . rest) 1)
+               'pos
+               'neg)))
+  
+#|
   
 ;                                               
 ;                                               
@@ -1977,7 +1765,7 @@
   
   (test/well-formed '(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?)))
   (test/well-formed '(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?)))
-
+|#
   
 ;                                                                                                                 
 ;                                                                                                                 
@@ -2024,8 +1812,9 @@
    'unconstrained-domain->4
    '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) #f))
   
+#|
   (test/spec-passed/result
-   'unconstrained-domain->4
+   'unconstrained-domain->5
    '((contract (->r ([size natural-number/c]
                      [proc (and/c (unconstrained-domain-> number?)
                                   (λ (p) (procedure-arity-includes? p size)))])
@@ -2035,7 +1824,7 @@
                'neg)
      10 +)
    55)
-  
+|#
   
 ;                              
 ;                              
@@ -2181,6 +1970,35 @@
 ;                                          
 ;                                          
 
+  (test/spec-passed
+   'and/c1
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) x)
+               'pos
+               'neg)
+     1))
+  
+  (test/neg-blame
+   'and/c2
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) x)
+               'pos
+               'neg)
+     200))
+  
+  (test/pos-blame
+   'and/c3
+   '((contract (and/c (-> (<=/c 100) (<=/c 100))
+                      (-> (>=/c -100) (>=/c -100)))
+               (λ (x) 200)
+               'pos
+               'neg)
+     1))
+  
+  
+  
   
   (test/spec-passed/result
    'and/c-ordering
@@ -2238,6 +2056,7 @@
                'pos 'neg)))
 
   
+#|
 
 ;                                                                                                                         
 ;                                                                                                                         
@@ -3395,7 +3214,8 @@
                       ,obj
                       'pos
                       'neg))))
-  
+  |#
+
 
 ;                                                                                    
 ;                                                                                    
@@ -4812,7 +4632,10 @@ so that propagation occurs.
       (provide/contract (contract-inferred-name-test2b (-> number? (values number? number?))))
       
       (define (contract-inferred-name-test3 x . y) x)
-      (provide/contract (contract-inferred-name-test3 (->* (number?) () (listof number?) (number?))))
+      (provide/contract (contract-inferred-name-test3 (->* (number?) () (listof number?) number?)))
+      
+      (define (contract-inferred-name-test4) 7)
+      (provide/contract (contract-inferred-name-test4 (->d () () any)))
 
       ))
   (contract-eval '(require 'contract-test-suite-inferred-name1))
@@ -4820,6 +4643,7 @@ so that propagation occurs.
   (test 'contract-inferred-name-test2 object-name (contract-eval 'contract-inferred-name-test2))
   (test 'contract-inferred-name-test2b object-name (contract-eval 'contract-inferred-name-test2b))
   (test 'contract-inferred-name-test3 object-name (contract-eval 'contract-inferred-name-test3))
+  (test 'contract-inferred-name-test4 object-name (contract-eval 'contract-inferred-name-test4))
   
   
 
@@ -4848,32 +4672,30 @@ so that propagation occurs.
   (test-name '(-> integer? integer?) (-> integer? integer?))
   (test-name '(-> integer? any) (-> integer? any))
   (test-name '(-> integer? (values boolean? char?)) (-> integer? (values boolean? char?)))
-  (test-name '(-> integer? boolean? (values char? any/c)) (->* (integer? boolean?) () (char? any/c)))
+  (test-name '(-> integer? boolean? (values char? any/c)) (->* (integer? boolean?) () (values char? any/c)))
   (test-name '(-> integer? boolean? any) (->* (integer? boolean?) () any))
   (test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any))
   
-  (test-name '(->* (integer?) (string?) boolean? (char? any/c)) (->* (integer?) (string?) boolean? (char? any/c)))
+  (test-name '(->* (integer?) (string?) boolean? (values char? any/c)) (->* (integer?) (string?) boolean? (values char? any/c)))
   (test-name '(->* (integer? char?) (boolean?) any) (->* (integer? char?) (boolean?) any))
   (test-name '(->* (integer? char? #:z string?) (integer?) any) (->* (#:z string? integer? char?) (integer?) any))
   (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) any) (->* (#:z string? integer? char?) (boolean? #:i number?) any))
   (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (listof integer?) any) 
              (->* (#:z string? integer? char?) (boolean? #:i number?) (listof integer?) any))
-  (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (number? boolean? symbol?)) 
-             (->* (#:z string? integer? char?) (boolean? #:i number?) (number? boolean? symbol?)))
-  (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (listof integer?) (number? boolean? symbol?)) 
-             (->* (#:z string? integer? char?) (boolean? #:i number?) (listof integer?) (number? boolean? symbol?)))
+  (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (values number? boolean? symbol?)) 
+             (->* (#:z string? integer? char?) (boolean? #:i number?) (values number? boolean? symbol?)))
+  (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (listof integer?) (values number? boolean? symbol?)) 
+             (->* (#:z string? integer? char?) (boolean? #:i number?) (listof integer?) (values number? boolean? symbol?)))
   
-  (test-name '(->d integer? boolean? ...) (->d integer? boolean? (lambda (x y) char?)))
-  (test-name '(->d* (integer? boolean?) ...) (->d* (integer? boolean?) (lambda (x y) char?)))
-  (test-name '(->d* (integer? boolean?) any/c ...) (->d* (integer? boolean?) any/c (lambda (x y . z) char?)))
+  (test-name '(->d () () any) (->d () () any))
+  (test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any) (->d ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any))
+  (test-name '(->d () () (values [x ...] [y ...])) (->d () () (values [x number?] [y number?])))
+  (test-name '(->d () () [x ...]) (->d () () [q number?]))
+  (test-name '(->d () () #:pre-cond ... [x ...]) (->d () () #:pre-cond #t [q number?]))
+  (test-name '(->d () () #:pre-cond ... [x ...] #:post-cond ...) (->d () () #:pre-cond #t [q number?] #:post-cond #t))
+  (test-name '(->d () () [x ...] #:post-cond ...) (->d () () [q number?] #:post-cond #t))
   
-  (test-name '(->r ((x ...)) ...) (->r ((x number?)) number?))
-  (test-name '(->r ((x ...) (y ...) (z ...)) ...) (->r ((x number?) (y boolean?) (z pair?)) number?))
-  (test-name '(->r ((x ...) (y ...) (z ...)) rest-x ... ...) 
-             (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))
-  (test-name '(->pp ((x ...)) ...) (->pp ((x number?)) #t number? blech #t))
-  
-  (test-name '(->r ((x ...)) ...) (case-> (->r ((x number?)) number?)))
+#|
   (test-name '(case-> (->r ((x ...)) ...) (-> integer? integer? integer?))
              (case-> (->r ((x number?)) number?) (-> integer? integer? integer?)))
   (test-name '(->r ((x ...) (y ...) (z ...)) ...)
@@ -4886,7 +4708,8 @@ so that propagation occurs.
   
   (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
              (case-> (-> integer? integer?) (-> integer? integer? integer?)))
-
+|#
+  
   (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))
   
   (test-name '(or/c) (or/c))
@@ -5104,6 +4927,12 @@ so that propagation occurs.
   (ctest #f contract-stronger? (-> integer? #:y integer? integer?) (-> integer? #:x integer? integer?))
   (ctest #t contract-stronger? (-> integer? #:x integer? integer?) (-> integer? #:x integer? integer?))
   (ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2)))
+  
+  (let ([c (contract-eval '(->* () () any))])
+    (test #t (contract-eval 'contract-stronger?) c c))
+  (let ([c (contract-eval '(->d () () any))])
+    (test #t (contract-eval 'contract-stronger?) c c))
+
   (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
   (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
   (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))
@@ -5229,14 +5058,10 @@ so that propagation occurs.
   (ctest #f contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y) #t))
   (ctest #t contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y #:x z) #t))
   
-  (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (char? any/c)) (λ (x . y) #f))
-  (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (char? any/c)) (λ (x y . z) #f))
-  (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (char? any/c)) (λ (x) #f))
-  (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (char? any/c)) (λ x #f))
-  
-  (ctest #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x))
-  (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x))
-  (ctest #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x))
+  (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x . y) #f))
+  (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x y . z) #f))
+  (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x) #f))
+  (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ x #f))
 
   (ctest #t contract-first-order-passes? (listof integer?) (list 1))
   (ctest #f contract-first-order-passes? (listof integer?) #f)
@@ -5247,36 +5072,9 @@ so that propagation occurs.
   
   (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1))
   (ctest #f contract-first-order-passes? (promise/c integer?) 1)
-  
-  (ctest #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t))
-  (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t))
-  (ctest #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t))
 
-  (ctest #t contract-first-order-passes? 
-        (->d* (integer? boolean?) any/c (lambda (x y . z) char?))
-        (λ (x y . z) z))
-  (ctest #t contract-first-order-passes? 
-        (->d* (integer? boolean?) any/c (lambda (x y . z) char?))
-        (λ (y . z) z))
-  (ctest #t contract-first-order-passes? 
-        (->d* (integer? boolean?) any/c (lambda (x y . z) char?))
-        (λ z z))
-  (ctest #f contract-first-order-passes? 
-        (->d* (integer? boolean?) any/c (lambda (x y . z) char?))
-        (λ (x y z . w) 1))
-  (ctest #f contract-first-order-passes? 
-        (->d* (integer? boolean?) any/c (lambda (x y . z) char?))
-        (λ (x y) 1))
-  
-  (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1))
-  (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1))
-  (ctest #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1))
-  (ctest #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1))
-  
-  (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1))
-  (ctest #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1))
-  (ctest #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1))
-  
+#|
+
   (ctest #f contract-first-order-passes? 
         (case-> (-> integer? integer?)
                 (-> integer? integer? integer?))
@@ -5309,6 +5107,7 @@ so that propagation occurs.
         (case-> (-> integer? integer?)
                 (-> integer? integer? integer?))
         (case-lambda [() 1] [(x) x] [(x y) x] [(x y z) x]))
+|#
   
   (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x))
   (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values)
@@ -5842,7 +5641,8 @@ so that propagation occurs.
                f))
       
       (eval '(require 'provide/contract23b))))
-  
+
+#|
   (test/spec-passed
    'provide/contract24
    '(begin
@@ -5850,6 +5650,7 @@ so that propagation occurs.
                (require (prefix-in c: scheme/contract))
                (c:case-> (c:-> integer? integer?)
                          (c:-> integer? integer? integer?))))))
+  |#
   
   ;; tests that contracts pick up the #%app from the context
   ;; instead of always using the scheme/base #%app.