Allow uses of recursive-contract to specify the type of contract to create.

collects/racket/contract/private/base.rkt

@@ -69,17 +69,41 @@ improve method arity mismatch contract violation error messages?
 
 (define-syntax (recursive-contract stx)
   (syntax-case stx ()
+    [(_ arg type)
+     (keyword? (syntax-e #'type))
+     (with-syntax ([maker
+                    (case (syntax-e #'type)
+                      [(#:impersonator) #'make-contract]
+                      [(#:chaperone) #'make-chaperone-contract]
+                      [(#:flat) #'make-flat-contract]
+                      [else (raise-syntax-error 'recursive-contract
+                                                "type must be one of #:impersonator, #:chaperone, or #:flat"
+                                                #'type)])]
+                   [coerce
+                    (case (syntax-e #'type)
+                      [(#:impersonator) #'coerce-contract]
+                      [(#:chaperone) #'coerce-chaperone-contract]
+                      [(#:flat) #'coerce-flat-contract]
+                      [else (raise-syntax-error 'recursive-contract
+                                                "type must be one of #:impersonator, #:chaperone, or #:flat"
+                                                #'type)])]
+                   [(type ...)
+                    (if (eq? (syntax-e #'type) '#:impersonator)
+                        null
+                        (list #'type))])
+       (syntax
+        (maker
+         #:name '(recursive-contract arg type ...)
+         #:first-order
+         (λ (val)
+           (let ([ctc (coerce 'recursive-contract arg)])
+             (contract-first-order-passes? ctc val)))
+         #:projection
+         (λ (blame)
+           (let ([ctc (coerce 'recursive-contract arg)])
+             (let ([f (contract-projection ctc)])
+               (λ (val)
+                 ((f blame) val))))))))]
     [(_ arg)
-     (syntax
+     (syntax/loc stx
-      (make-contract
+       (recursive-contract arg #:impersonator))]))
-       #:name '(recursive-contract arg)
-       #:first-order
-       (λ (val)
-         (let ([ctc (coerce-contract 'recursive-contract arg)])
-           (contract-first-order-passes? ctc val)))
-       #:projection
-       (λ (blame)
-          (let ([ctc (coerce-contract 'recursive-contract arg)])
-            (let ([f (contract-projection ctc)])
-              (λ (val)
-                 ((f blame) val)))))))]))

collects/scribblings/reference/contracts.scrbl

@@ -1792,10 +1792,14 @@ the message that indicates the violation.
 }
 
 
-@defform[(recursive-contract contract-expr)]{
+@defform*[[(recursive-contract contract-expr)
+           (recursive-contract contract-expr type)]]{
 
 Delays the evaluation of its argument until the contract is checked,
-making recursive contracts possible.}
+making recursive contracts possible.  If @racket[type] is given, it
+describes the expected type of contract and must be one of the keywords
+@racket[#:impersonator], @racket[#:chaperone], or @racket[#:flat].  If
+@racket[type] is not given, an impersonator contract is created.}
 
 
 @defform[(opt/c contract-expr)]{

collects/tests/racket/contract-test.rktl

@@ -8097,6 +8097,26 @@
               'pos
               'neg))
   
+  (test/spec-passed
+   'recursive-contract6
+   '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))])
+      (contract ctc (cons 1 (cons 2 3)) 'pos 'neg)))
+  
+  (test/pos-blame
+   'recursive-contract7
+   '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))])
+      (contract ctc (cons 1 (cons 2 #t)) 'pos 'neg)))
+  
+  (test/pos-blame
+   'recursive-contract8
+   '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat)))])
+      (contract ctc (cons 1 (cons #t 3)) 'pos 'neg)))
+  
+  (test/spec-passed
+   'recursive-contract9
+   '(letrec ([ctc (or/c number? (hash/c (recursive-contract ctc #:chaperone) number?))])
+      (make-hash (list (cons (make-hash (list (cons 3 4))) 5)))))
+  
   
 
 ;                                                       
@@ -9108,6 +9128,19 @@ so that propagation occurs.
   (ctest #t contract?           (box/c trivial-proxy-ctc #:immutable #t))
   (ctest #f chaperone-contract? (box/c trivial-proxy-ctc #:immutable #t))
   (ctest #f flat-contract?      (box/c trivial-proxy-ctc #:immutable #t))
+  
+  ;; Test the ability to create different types of contracts with recursive-contract
+  (ctest #t flat-contract? (letrec ([ctc (or/c number? 
+                                               (cons/c (recursive-contract ctc #:flat)
+                                                       (recursive-contract ctc #:flat)))])
+                             ctc))
+  
+  (ctest #f flat-contract? (letrec ([ctc (or/c number? 
+                                               (box/c (recursive-contract ctc #:chaperone)))])
+                             ctc))
+  (ctest #t chaperone-contract? (letrec ([ctc (or/c number? 
+                                                    (box/c (recursive-contract ctc #:chaperone)))])
+                                  ctc))
 
   (ctest #t contract? 1)
   (ctest #t contract? (-> 1 1))