From 535414282506f322459014355e69ac0cca8360ec Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 28 Nov 2014 12:32:09 -0600 Subject: [PATCH] give pair? the same treament as list? got in 9ee9f676 --- racket/collects/racket/contract/private/guts.rkt | 8 ++++++-- racket/collects/racket/contract/private/misc.rkt | 10 +++++++--- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index efa540f60d..10b3b6abcb 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -52,7 +52,7 @@ contract-custom-write-property-proc (rename-out [contract-custom-write-property-proc custom-write-property-proc]) - set-listof-any!) + set-listof-any-and-cons/c-anyany!) (define (contract-custom-write-property-proc stct port display?) (write-string "#<" port) @@ -219,7 +219,10 @@ ;; the files are not set up for that, so we just ;; bang it in here and use it only after it's been banged in. (define listof-any #f) -(define (set-listof-any! c) (set! listof-any c)) +(define consc-anyany #f) +(define (set-listof-any-and-cons/c-anyany! l p) + (set! listof-any l) + (set! consc-anyany p)) (define (coerce-contract/f x [name name-default]) (define (coerce-simple-value x) @@ -228,6 +231,7 @@ [(and (procedure? x) (procedure-arity-includes? x 1)) (cond [(and (eq? x list?) listof-any) listof-any] + [(and (eq? x pair?) consc-anyany) consc-anyany] [else (make-predicate-contract (if (name-default? name) (or (object-name x) '???) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 1902296a7e..77aa3d1f99 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -886,7 +886,11 @@ (define (cons/c-name ctc) (define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-cdr (the-cons/c-tl-ctc ctc)) - (build-compound-type-name 'cons/c ctc-car ctc-cdr)) + (cond + [(and (any/c? ctc-car) (any/c? ctc-cdr)) + 'pair?] + [else + (build-compound-type-name 'cons/c ctc-car ctc-cdr)])) (define (cons/c-stronger? this that) (define this-hd (the-cons/c-hd-ctc this)) @@ -1959,5 +1963,5 @@ [else "th"]))) ;; this is a hack to work around cyclic linking issues; -;; see definition of set-listof-any! -(set-listof-any! (listof any/c)) +;; see definition of set-listof-any-and-cons/c-anyany! +(set-listof-any-and-cons/c-anyany! (listof any/c) (cons/c any/c any/c))