fixed the contract? predicate so that it recognizes thigns that aren't yet turned into contract structs

svn: r12043

collects/scheme/private/contract-ds.ss

@@ -467,12 +467,12 @@ it around flattened out.
 
 (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
   (cond
-    [(and (andmap contract? list-of-subcontracts) (not attrs))
+    [(and (andmap name-pred? list-of-subcontracts) (not attrs))
      (apply build-compound-type-name name/c list-of-subcontracts)]
     [else
      (let ([fields 
             (map (λ (field ctc) 
-                   (if (contract? ctc)
+                   (if (name-pred? ctc)
                        (build-compound-type-name field ctc)
                        (build-compound-type-name field '...)))
                  fields

collects/scheme/private/contract-guts.ss

@@ -142,7 +142,7 @@
 ;; returns #f if the argument could not be coerced to a contract
 (define (coerce-contract/f x)
   (cond
-    [(contract? x) x]
+    [(proj-pred? x) x]
     [(and (procedure? x) (procedure-arity-includes? x 1)) 
      (make-predicate-contract (or (object-name x) '???) x)]
     [(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
@@ -349,7 +349,7 @@
   (let ([ctc (coerce-contract 'contract-name ctc)])
     ((name-get ctc) ctc)))
 
-(define (contract? x) (proj-pred? x))
+(define (contract? x) (and (coerce-contract/f x) #t))
 (define (contract-proc ctc) ((proj-get ctc) ctc))
 
 (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
@@ -367,7 +367,7 @@
        '()]
       [else (let ([sub (car subs)])
               (cond
-                [(contract? sub)
+                [(name-pred? sub)
                  (let ([mk-sub-name (contract-name sub)])
                    `(,mk-sub-name ,@(loop (cdr subs))))]
                 [else `(,sub ,@(loop (cdr subs)))]))])))

collects/scheme/private/contract.ss

@@ -765,17 +765,12 @@ improve method arity mismatch contract violation error messages?
      (syntax (make-proj-contract 
               '(recursive-contract arg) 
               (λ (pos-blame neg-blame src str)
-                (let ([proc (contract-proc arg)])
-                  (λ (val)
-                    ((proc pos-blame neg-blame src str) val))))
+                (let ([ctc (coerce-contract 'recursive-contract arg)])
+                  (let ([proc (contract-proc ctc)])
+                    (λ (val)
+                      ((proc pos-blame neg-blame src str) val)))))
               #f))]))
 
-(define (check-contract ctc)
-  (unless (contract? ctc)
-    (error 'recursive-contract "expected a contract, got ~e" ctc))
-  ctc)
-
-
 ;                                                                                                   
 ;                                                                                                   
 ;                                                                                                   

collects/tests/mzscheme/contract-test.ss

@@ -3698,6 +3698,13 @@
                         f))])
         ((((contract ctc f 'pos 'neg) 1) 2) 3))))
   
+  (test/spec-passed
+   'recursive-contract5
+   '(contract (recursive-contract #f)
+              #f
+              'pos
+              'neg))
+  
   
 
 ;                                                       
@@ -4510,6 +4517,9 @@ so that propagation occurs.
                             (define-struct s (a b))
                             (struct/c s any/c any/c)))
   
+  (ctest #t contract? 1)
+  (ctest #t contract? (-> 1 1))
+  
   (test-flat-contract '(and/c number? integer?) 1 3/2)
 
   (test-flat-contract '(not/c integer?) #t 1)